10:19 AM 15-DEC-99 MAS Patches 3,2,1 routines ADGCRB5 ADGCRB5 ; IHS/ADC/PDW/ENM - A SHEET lines 8-11 ; [ 12/15/1999 10:01 AM ] ;;5.0;ADMISSION/DISCHARGE/TRANSFER;**3**;MAR 25, 1999 ; A ;EP -- driver D VSIT Q:'DGVSDA K DGZN D H8,VPOV,H9,VPRC,H10,VINP Q ; H8 ; -- sub heading 8 W !,DGLIN,!,"26 ICD9 27 Hosp Acq",?24,"28 Established DX",!,DGLIN1 Q ; VSIT ; -- visit DGFN ;IHS/DSD/ENM 10/18/99 A Break Cmd was removed from this line S DGVSDA=$$VISIT I DGDS,'DGVSDA W !!,"*** No visit for day surgery entry yet ***" Q W:'DGVSDA !!,"*** no visit created for this admission - incomplete ***" Q ; VPOV ; -- diagnosis N X,Y,Z S X=0 F S X=$O(^AUPNVPOV("AD",DGVSDA,X)) Q:'X D . Q:'$D(^AUPNVPOV(X,0)) S Y=^(0) Q:'Y!('$D(^ICD9(+Y,0))) . W !?3,$P(^ICD9(+Y,0),U),?13,$S($P(Y,U,7)=1:"X",1:"") . S:$P(Y,U,9)'="" DGPOVDA=X,DGPOVN0=Y . Q:'+$P(Y,U,4)!('$D(^AUTNPOV(+$P(Y,U,4),0))) . S Z=$P(^AUTNPOV(+$P(Y,U,4),0),U) I $L(Z)<53 W ?27,Z Q . D WRAP(Z,27,79,"") Q ; H9 ; -- sub heading 9 W !,DGLIN1,!,"29 ICD9 30 DX",?18,"31 Op & Selec Procedures" W ?55,"32 Post-Op 33 33a Op" W !?3,"Code",?58,"Infec Date Phy Code",!,DGLIN1 Q ; VPRC ; -- procedures N DGX,DGY S DGX=0 F S DGX=$O(^AUPNVPRC("AD",DGVSDA,DGX)) Q:'DGX D . Q:'$D(^AUPNVPRC(DGX,0)) S DGY=^(0) Q:'DGY!('$D(^ICD0(+DGY,0))) . W !?3,$P(^ICD0(+DGY,0),U) .; S X=$P(DGY,U,5) I X]"" W ?12,$P($G(^ICD9(X,0)),U) ;dx . S X=$P(DGY,U,4) I X]"" D ;prov narr .. Q:'+$P(DGY,U,4)!('$D(^AUTNPOV(+$P(DGY,U,4),0))) .. S X=$P(^AUTNPOV(+$P(DGY,U,4),0),U) I $L(X)<38 W ?21,X Q .. D WRAP(X,21,58,"") . W ?60,$S($P(DGY,U,8)="Y":"YES",1:" NO"),?66,$E($P(DGY,U,6),4,7) . Q:'+$P(DGY,U,11) . I $P(^DD(9000010.06,.01,0),U,2)["200" D Q .. W ?72,$$VAL^XBDIQ1(200,+$P(DGY,U,11),9999999.039) . W ?72,$$VAL^XBDIQ1(6,+$P(DGY,U,11),9999999.039) Q ; H10 ; -- sub heading 10 I DGDS W !,DGLIN1,!,"34 Post-op Comments",! Q W !,DGLIN1,!,"34 Discharge Type" W ?27,"35 Facility Transferred To",?63,"36 Facility Code",! Q ; VINP ; -- hospitalization I DGDS D DSCMTS Q N X,X1,Y S X=$O(^AUPNVINP("AD",DGVSDA,0)) Q:'X Q:'$D(^AUPNVINP(X,0)) S Y=^(0) S X=$P(Y,U,6) I X]"" W ?3,$E($P(^DG(405.1,X,0),U),1,24) ;dsch type S X1=$P(Y,U,9) I +X1 D ; -- facility & code . W ?30,$P(@(U_$P(X1,";",2)_+X1_",0)"),U) . I $P(X1,";",2)'="DIC(4," Q . W ?66,$P($G(^AUTTLOC(+X1,0)),U,10) ; ; -- sub heading 11 W !,DGLIN1,!,"37 Disch Service",?24,"38 Disch Srv Code" W ?55,"39 # Consults",! ; S X1=$P(Y,U,5) I +X1 D ; -- discharge service & code . Q:'$D(^DIC(45.7,+X1,0)) W ?3,$P(^(0),U) . Q:'$D(^DIC(45.7,X1,9999999)) W ?30,$P(^(9999999),U) W ?63,$P(Y,U,8) ;# consults Q ; DSCMTS ; -- day surgery comments NEW S0,S2,Y,LINE S S0=$G(^ADGDS(DFN,"DS",DGDS,0)),S2=$G(^(2)),LINE="" S Y=$P(S0,U,7) I Y]"" D DD^%DT S LINE=LINE_"Sent to Observation @ "_Y I $P(S2,U,5)="Y" S LINE=LINE_" UNESCORTED" S LINE=LINE_$$ADMDS S LINE=LINE_" "_$P(S2,U,6) W ?2,LINE Q ; ADMDS() ; -- admit after ds NEW SDT,X1,X2,X,Y,SAV,LMT,ADT S (SDT,X1)=$P(DGN,U),X2=$P(DGOPT("QA1"),U,2) I X1=""!(X2="") Q "" D C^%DTC S Y=$O(^DGPM("APTT1",DFN,SDT)) I Y="" Q "" I Y>X Q "" S SAV=Y D DD^%DT S ADT=Y S X1=SAV,X2=SDT D ^%DTC S LMT=X Q " Admitted on "_ADT_" ("_LMT_" days after surgery)" ; VISIT() ; -- visit ifn I DGDS Q $$DSV N X,Y,Z S Y=(9999999-$P(+DGN,"."))_"."_$E($P(+DGN,".",2),1,4),Z=0 ;maw mod ;N X,Y,Z S Y=(9999999-$P(+DGN,"."))_"."_$P(+DGN,".",2),Z=0 ;maw orig S X=0 F S X=$O(^AUPNVSIT("AA",DFN,Y,X)) Q:'X D . Q:'$D(^AUPNVSIT(X,0)) Q:$P(^(0),U,11)=1 Q:$P(^(0),U,7)'="H" S Z=X Q Z ; DSV() ;EP -- ds visit ifn NEW REVDT,V,DATE,Y S DATE=$P(^ADGDS(DFN,"DS",DGDS,0),U) I DATE="" Q 0 S REVDT=9999999-$P(DATE,"."),REVDT=REVDT_"."_$P(DATE,".",2) S (Y,V)=0 F Q:Y=1 S V=$O(^AUPNVSIT("AA",DFN,REVDT,V)) Q:'V D . Q:'$O(^AUPNVPOV("AD",V,0)) ;searhc maw coded visit 4/16/98 . Q:'$O(^AUPNVPRV("AD",V,0)) ;searhc maw coded visit 4/16/98 . I $P(^AUPNVSIT(V,0),U,7)="S" S Y=1 Q $S(Y=1:V,1:0) ; WRAP(X,DIWL,DIWR,DIWF) ; -- print text fields in word-wrap mode K ^UTILITY($J,"W") D ^DIWP S X=0 F S X=$O(^UTILITY($J,"W",DIWL,X)) Q:X="" D . W:$X>DIWL ! W ?DIWL,^UTILITY($J,"W",DIWL,X,0) K ^UTILITY($J,"W") Q ADGCRB6 ADGCRB6 ; IHS/ADC/PDW/ENM - A SHEET lines 12-14 ; [ 10/19/1999 10:27 AM ] ;;5.0;ADMISSION/DISCHARGE/TRANSFER;**3**;MAR 25, 1999 ; A ; -- driver I DGDS D H14,L14 Q D H12,L12,H13,H14,L14 Q ; H12 ; -- sub heading 12 W !,DGLIN1,!,"40 Injury Date 41 Alleged Injury Cause" W ?41,"42 E-Code",?51,"43 Place of Injury 44 Code",! Q ; L12 ; -- data line 12 (injury data) Q:'$D(DGPOVDA) W ?3,$$IDT,?17,$P($$ICD,U,2),?44,$P($$ICD,U),?54,$$PLC W ?75,$P(DGPOVN0,U,11) Q ; H13 ; -- underlying cause of death N DGN11 S DGN11=$G(^AUPNPAT(DFN,11)) ;IHS/DSD/ENM 10/19/99 N X S X=$P(DGN11,U,14) Q:'X W !,DGLIN1,!,"47 Underlying Cause of Death & Code",! W ?49,$E($P(^ICD9(X,0),U,3),1,16),?67,$P(^(0),U) Q ; H14 ; -- sub heading 14 W !,DGLIN1,!,"49 Date Printed",?17,"50 Attending Physician" I DGDS W ?42,"50a Phys Code",?62,"51 Printed By",! Q W ?42,"50a Phys Code",?58,"51 Admit Clerk/Coder",! Q ; L14 ; -- data line 14 B W ?4,$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3) I DGDS D Q . W ?21,$P($$PRV,U),?47,$P($$PRV,U,2),?66,$P(^VA(200,DUZ,0),U,2),! W ?21,$P($$PRV,U),?47,$P($$PRV,U,2),?66,$$ADMCLK,$$CODER,! Q ; IDT() ; -- injury date N Y S Y=$P(DGPOVN0,U,13) Q:'Y "" X ^DD("DD") Q Y ; ICD() ; -- cause of injury Q $P($G(^ICD9(+$P(DGPOVN0,U,9),0)),U)_U_$P($G(^(0)),U,3) ; PLC() ; -- place of injury N Y,C S Y=$P(DGPOVN0,U,11) Q:Y="" "" S C=^DD(9000010.07,.11,0) D Y^DIQ Q Y ; PRV() ; -- provider name & code N X,Y,DA,DGAR,PROV S X=0 F S X=$O(^AUPNVPRV("AD",DGVSDA,X)) Q:'X D . Q:'$D(^AUPNVPRV(X,0)) S:$P(^(0),U,4)="P" DA=+^(0) I '$D(DA) Q "" I $P(^DD(9000010.06,.01,0),U,2)["200" S PROV=DA E S PROV=$G(^DIC(16,DA,"A3")) I PROV="" Q "" K DGAR D ENP^XBDIQ1(200,PROV,".01;9999999.039","DGAR(") Q DGAR(.01)_U_DGAR(9999999.039) ; ADMCLK() ; -- admitting clerk NEW X S X=$P($G(^DGPM(DGFN,"USR")),U) I X="" Q X Q $P($G(^VA(200,X,0)),U,2) ; CODEROLD() ; -- coding clerk N DGX,DA,PROV,DGAR,ANS S DGX=0 F S DGX=$O(^AUPNVPRV("AD",DGVSDA,DGX)) Q:'DGX!($D(ANS)) D . Q:'$D(^AUPNVPRV(DGX,0)) Q:$P(^(0),U,4)="P" S DA=+^(0) . I $P(^DD(9000010.06,.01,0),U,2)["200" S PROV=DA . E S PROV=$G(^DIC(16,DA,"A3")) Q:PROV="" . K DGAR D ENP^XBDIQ1(200,PROV,"1;53.5","DGAR(","I") . Q:DGAR(53.5)="" . Q:$$VAL^XBDIQ1(7,DGAR(53.5,"I"),9999999.01)'="88" . S ANS="/"_DGAR(1) Q $G(ANS) ; CODER() ;-- coding clerk searhc/maw 4/17/98 N DGCD,DGX,DGXIEN S DGX=0 F S DGX=$O(^APCDFORM("AB",DGVSDA,DGX)) Q:DGX="" D . S DGXIEN=$O(^APCDFORM("AB",DGVSDA,DGX,0)) . I '$D(^APCDFORM(DGX,11,DGXIEN,0)) S DGCD="" Q DGCD . S DGCD=$P(^APCDFORM(DGX,11,DGXIEN,0),U,2) . S DGCD=$P(^VA(200,DGCD,0),U,2) . S DGCD="/"_DGCD Q $G(DGCD) ;IHS/DSD/ENM 02/19/99 ; ADGDSN ADGDSN ; IHS/ADC/PDW/ENM - PATIENTS NOT RELEASED FROM DAY SURGERY ; [ 06/14/1999 10:19 AM ] ;;5.0;ADMISSION/DISCHARGE/TRANSFER;**2**;MAR 25, 1999 ; ;***> get date range and device W !!?10,"PRINT LIST OF PATIENTS NOT RELEASED FROM DAY SURGERY" DATE S %DT="AEQ",%DT("A")="Beginning date: ",X="" D ^%DT G END:Y=-1 S DGBDT=Y DATE2 S %DT="AEQ",%DT("A")="Ending date: ",X="" D ^%DT G DATE:Y=-1 S DGEDT=Y I DGEDT calculate patients not released; screen out no-shows & cancels S DGDT=DGBDT-.0001,DGEDT=DGEDT_.2400 K ^TMP("DGZDSN",$J) A1 S DGDT=$O(^ADGDS("AA",DGDT)) G PRNT:DGDT="",PRNT:DGDT>DGEDT S DFN=0 A2 S DFN=$O(^ADGDS("AA",DGDT,DFN)) G A1:DFN="" S DGN=0 A3 S DGN=$O(^ADGDS("AA",DGDT,DFN,DGN)) G A2:DGN="" G A3:'$D(^ADGDS(DFN,"DS",DGN,0)) G A4:'$D(^ADGDS(DFN,"DS",DGN,2)) S DGSTR=^(2) G A3:$P(DGSTR,U)'="",A3:$P(DGSTR,U,3)="Y",A3:$P(DGSTR,U,4)="Y" A4 S ^TMP("DGZDSN",$J,DGDT,DFN)="" G A3 ; PRNT ;***> print list S DGDT=0,DGSTOP="",DGPAGE="" S DGLIN="",$P(DGLIN,"=",80)="" S DGFAC=$P(^DIC(4,DUZ(2),0),U),DGDUZ=$P(^VA(200,DUZ,0),U,2) D HEAD PR1 S DGDT=$O(^TMP("DGZDSN",$J,DGDT)) G END1:DGDT="" S DFN=0 PR2 S DFN=$O(^TMP("DGZDSN",$J,DGDT,DFN)) G PR1:DFN="" S DGT=$P(DGDT,".",2),DGT=$E(DGT_"000",1,4) S X=$P(DGDT,"."),X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)_" at "_DGT W !?3,$P(^DPT(DFN,0),U) W:$D(^AUPNPAT(DFN,41,DUZ(2),0)) ?30,$J($P(^(0),U,2),7) W ?50,X D NEWPG:($Y>(IOSL-6)) G END2:DGSTOP=U G PR2 ; ; END1 ;***> eoj I IOST["C-" D PRTOPT^ADGVAR END2 W @IOF D KILL^ADGUTIL D ^%ZISC K ^TMP("DGZDSN",$J) Q ; ; NEWPG ;***> subrtn for end of page control I IOST'?1"C-".E D HEAD S DGSTOP="" Q I DGPAGE>0 K DIR S DIR(0)="E" D ^DIR S DGSTOP=X I DGSTOP'=U D HEAD Q ; HEAD ;***> subrtn to print heading I (IOST["C-")!(DGPAGE>0) W @IOF S DGPAGE=DGPAGE+1 W ?11,"*****Confidential Patient Data Covered by Privacy Act*****" W !,DGDUZ,?80-$L(DGFAC)\2,DGFAC W ! D TIME^ADGUTIL W ?23,"DAY SURGERY PATIENTS NOT RELEASED" W !!!?3,"PATIENT NAME",?30,"CHART #",?50,"SURGERY DATE/TIME" W !,DGLIN,!! Q ADGDSQA ADGDSQA ; IHS/ADC/PDW/ENM - DAY SURGERY PROVIDER QA REPORT ; [ 07/16/1999 3:16 PM ] ;;5.0;ADMISSION/DISCHARGE/TRANSFER;**3**;MAR 25, 1999 ; W @IOF,!!!?28,"DAY SURGERY PROVIDER QA REPORT",!! ;***> get date range BDATE S %DT="AEQ",%DT("A")="Select beginning date: ",X="" D ^%DT G END:Y=-1 S DGBDT=Y EDATE S %DT="AEQ",%DT("A")="Select ending date: ",X="" D ^%DT G END:Y=-1 S DGEDT=Y ; PROV ;***> select one or all providers K DIR S DIR(0)="Y",DIR("A")="Print Report for ALL Providers" S DIR("B")="NO",DIR("?")="Answer NO to print for only ONE provider" D ^DIR S DGPV=Y G EDATE:$D(DUOUT),END:$D(DTOUT),END:$D(DIROUT) ONE I Y=0 K DIR S DIR(0)="PO^6:EMQZ" D ^DIR G PROV:$D(DIRUT),ONE:Y=-1 S DGPV=Y ; ;***> get print device W !!,*7,"Report requires wide printer or condensed print.",! S %ZIS="PQ" D ^%ZIS G END:POP,QUE:$D(IO("Q")) U IO G CALC QUE K IO("Q") S ZTRTN="CALC^ADGDSQA",ZTDESC="DAY SURG PROV QA" ;F DGI="DGBDT","DGEDT","DGPV" S ZTSAVE(DGI)="" F DGI="DGBDT","DGEDT","DGPV","DGOPT(""GEN"")","DGOPT(""QA"")","DGOPT(""QA1"")" S ZTSAVE(DGI)="" D ^%ZTLOAD D ^%ZISC K ZTSK END K Y,DGBDT,DGEDT D HOME^%ZIS Q ; ; CALC ;***> Set up sorted utility file for date range S DGDT=DGBDT-.0001,DGEDT=DGEDT+.2400 K ^TMP($J) C1 S DGDT=$O(^ADGDS("AA",DGDT)) G NEXT:DGDT="",NEXT:DGDT>DGEDT S DFN=0 C2 S DFN=$O(^ADGDS("AA",DGDT,DFN)) G C1:DFN="" S DGDFN1=0 C3 S DGDFN1=$O(^ADGDS("AA",DGDT,DFN,DGDFN1)) G C2:DGDFN1="" G C3:'$D(^ADGDS(DFN,0)),C3:'$D(^ADGDS(DFN,"DS",DGDFN1,0)) S DGSTR=^(0) S (DGPRV,DGPRC,DGSRV,DGOBS,DGADM,DGADWK,DGNM,DGCMT)="" S DGPRV=$P(DGSTR,U,6) I DGPV'=1,DGPRV'=+DGPV G C3 ;wrong provider ; ;***> check for sent to obs, admit S DGSTR2=$G(^ADGDS(DFN,"DS",DGDFN1,2)),DGADM=$P(DGSTR2,U,2) ;admit? S DGOBS=$P(DGSTR,U,7) G C4:DGADM="Y" ;obsrv?/skip next lines if admit ; ;***> check if admitted w/in time limit in site parameters S Y=9999999-DGDT,X1=$P(DGDT,"."),X2=$P(DGOPT("QA1"),U,2) D C^%DTC S DGX=9999999-X S DGX=$O(^DGPM("ATID1",DFN,DGX)) I DGX'="",DGX'>Y S DGADWK=9999999-DGX ; C4 I (DGOBS="")&(DGADM="")&(DGADWK="") G C3 ; ;***> set variables of data items to be printed S DGCHT=$S($D(^AUPNPAT(DFN,41,DUZ(2),0)):$P(^(0),U,2),1:"??") ;chrt # S DGPRC=$P(DGSTR,U,2),DGSRV=$P(DGSTR,U,5) ;procedure/service S:DGSRV'="" DGSRV=$P($G(^DIC(45.7,DGSRV,0)),U) S DGCMT=$P($G(DGSTR2),U,6) S DGNM=$P(^DPT(DFN,0),U) ;comment/patient ; S ^TMP($J,$P(DGDT,"."),DGNM,DFN)=DGCHT_U_DGSRV_U_DGPRV_U_DGPRC_U_DGOBS_U_DGADM_U_DGADWK_U_DGCMT G C3 ; ;***> go to print rtn NEXT G ^ADGDSQA1 ADGDSST ADGDSST ; IHS/ADC/PDW/ENM - DAY SURGERY STATISTICS BY SERVICE ; [ 07/16/1999 3:21 PM ] ;;5.0;ADMISSION/DISCHARGE/TRANSFER;**3**;MAR 25, 1999 ; W @IOF,!!!?18,"DAY SURGERY STATISTICS BY SERVICE",!! ;***> get date range BDATE S %DT="AEQ",%DT("A")="Select beginning date: ",X="" D ^%DT G END:Y=-1 S DGBDT=Y EDATE S %DT="AEQ",%DT("A")="Select ending date: ",X="" D ^%DT G END:Y=-1 S DGEDT=Y ; ;***> get print device S %ZIS="PQ" D ^%ZIS G END:POP,QUE:$D(IO("Q")) U IO G CALC QUE K IO("Q") S ZTRTN="CALC^ADGDSST",ZTDESC="DAY SURGERY STATS" ;IHS/DSD/ENM 07/16/99 NEXT LINE COPIED/MOD ;S ZTSAVE("DGBDT")="",ZTSAVE("DGEDT")="" F DGI="DGBDT","DGEDT","DGPV","DGOPT(""GEN"")","DGOPT(""QA"")","DGOPT(""QA1"")" S ZTSAVE(DGI)="" D ^%ZTLOAD D ^%ZISC K ZTSK END K Y,DGBDT,DGEDT D HOME^%ZIS Q ; ; CALC ;***> sort by surgery date and find service and age S DGDT=DGBDT-.9999 C1 S DGDT=$O(^ADGDS("AA",DGDT)) G PRINT:DGDT="",PRINT:DGDT>(DGEDT_.2400) S DFN=0 C2 S DFN=$O(^ADGDS("AA",DGDT,DFN)) G C1:DFN="" S DGN=0 C3 S DGN=$O(^ADGDS("AA",DGDT,DFN,DGN)) G C2:DGN="" G C3:'$D(^ADGDS(DFN,"DS",DGN,0)) S DGSRV=$P(^(0),U,5) I $D(^ADGDS(DFN,"DS",DGN,2)) G C3:$P(^(2),U,3)="Y" G C3:$P(^(2),U,4)="Y" S:DGSRV'="" DGSRV=$S($D(^DIC(45.7,DGSRV,0)):$P(^(0),U),1:"") S AGE=$$VAL^XBDIQ1(9000001,DFN,1102.99) I AGE="" S ^TMP($J,"ERR",DFN)="Date of Birth missing or invalid" G C3 I AGE'<$P(DGOPT("GEN"),U,5) S DGA(DGSRV,"A")=$S($D(DGA(DGSRV,"A")):DGA(DGSRV,"A")+1,1:1) S:'$D(DGA(DGSRV,"P")) DGA(DGSRV,"P")=0 E S DGA(DGSRV,"P")=$S($D(DGA(DGSRV,"P")):DGA(DGSRV,"P")+1,1:1) S:'$D(DGA(DGSRV,"A")) DGA(DGSRV,"A")=0 G C3 ; PRINT ;***> print S DGFAC=$P(^DIC(4,DUZ(2),0),U),DGDUZ=$P(^VA(200,DUZ,0),U,2) S (DGLIN,DGLIN1)="",$P(DGLIN,"-",80)="",$P(DGLIN1,"=",80)="" ; S (DGSRV,DGPAGE)=0 D HEAD P1 S DGSRV=$O(DGA(DGSRV)) G EXIT:DGSRV="" W !?3,DGSRV W ?29,$J(DGA(DGSRV,"A"),3),?41,$J(DGA(DGSRV,"P"),3) W ?63,$J(DGA(DGSRV,"A")+DGA(DGSRV,"P"),4) G P1 ; ;***> print totals EXIT W !,DGLIN,!!!?3,"TOTALS:" S (DGX,DGY)=0 F S DGX=$O(DGA(DGX)) Q:DGX="" S DGY=DGY+DGA(DGX,"A") S (DGX1,DGY1)=0 F S DGX1=$O(DGA(DGX1)) Q:DGX1="" S DGY1=DGY1+DGA(DGX1,"P") W ?28,$J(DGY,4),?40,$J(DGY1,4),?63,$J((DGY+DGY1),4) ; END1 ;***> eoj I IOST["C-" D PRTOPT^ADGVAR W @IOF D KILL^ADGUTIL D ^%ZISC Q ; ; HEAD ;***> subrtn to print heading I (IOST["C-")!(DGPAGE>0) W @IOF W !,DGDUZ,?82-$L(DGFAC)\2,DGFAC S DGPAGE=DGPAGE+1 W ! D TIME^ADGUTIL W ?23,"DAY SURGERY STATISTICS BY SERVICE" S DGX=$E(DGBDT,4,5)_"/"_$E(DGBDT,6,7)_"/"_($E(DGBDT,1,3)+1700) S DGY=$E(DGEDT,4,5)_"/"_$E(DGEDT,6,7)_"/"_($E(DGEDT,1,3)+1700) W !,$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3),?24,"from ",DGX," to ",DGY W !!?5,"SERVICE",?29,"ADULT",?41,"PEDS",?57,"TOTAL FOR SERVICE" W !,DGLIN1,! Q ADGGFL ADGGFL ;searhc/maw - ADG CONVERT V HOSP FILE POINTERS [ 05/13/1999 2:45 PM ] ;;5.0;ADMISSION/DISCHARGE/TRANSFER;**1**;MAY 04, 1999 ; ;this routine will go through the admission type file and the ;discharge type files and get their corresponding entries with ;the new facility movement file ; MAIN ;-- this is the main routine driver D ADT,DIT D GET Q:POP D SET,END Q ; ADT ;-- this is where i get the admission iens W !!,"I am getting the new admission type pointers" S FMNM=0 F S FMNM=$O(^DIC(42.1,"B",FMNM)) Q:FMNM="" D . S FMIEN=0 F S FMIEN=$O(^DIC(42.1,"B",FMNM,FMIEN)) Q:FMIEN="" D .. Q:'$D(^DG(405.1,"B",FMNM)) .. S ADT(FMIEN)=$O(^DG(405.1,"B",FMNM,0)) .. W "." Q ; DIT ;-- this is where i get the discharge iens W !,"I am getting the new discharge type pointers..." S FMNM=0 F S FMNM=$O(^DIC(42.2,"B",FMNM)) Q:FMNM="" D . S FMIEN=0 F S FMIEN=$O(^DIC(42.2,"B",FMNM,FMIEN)) Q:FMIEN="" D .. Q:'$D(^DG(405.1,"B",FMNM)) .. S DIT(FMIEN)=$O(^DG(405.1,"B",FMNM,0)) .. W "." Q ; GET ;-- go through the hospital location file and grab bad data nodes W !,"I will now search for entries in the V Hospitalization file " W "that are incomplete." W !,"At the end of this search, I will print a list of incomplete " W "data nodes." H 2 ;IHS/DSD/ENM 01/26/99 NEXT LINE COPIED/MODIFIED ;S (ENT,HLF)=0 F S HLF=$O(^AUPNVINP(HLF)) Q:HLF'?.N D S (ENT,HLF)=0 F S HLF=$O(^AUPNVINP(HLF)) Q:'HLF!(HLF'?.N) D . S ENT=ENT+1 . I ENT=25 W "." S ENT=0 . I '$D(^AUPNVINP(HLF)) S ^TMP($J,HLF)="NO DATA IN NODE" . I $P(^AUPNVINP(HLF,0),U,7)="" S ^TMP($J,HLF)="NO ADMISSION TYPE" . I $P(^AUPNVINP(HLF,0),U,6)="" S ^TMP($J,HLF)="NO DISCHARGE TYPE" ;IHS/ASDST/ENM 12/29/98 ABOVE TWO LINES MODIFIED 6 AND 7 REV W @IOF D ^%ZIS I POP W !,"You must rerun this conversion before continuing, D ^ADGGFL when ready" Q W !,"The following data nodes have incomplete data:" S (CNT,TMPA)=0 F S TMPA=$O(^TMP($J,TMPA)) Q:TMPA="" D . Q:'$D(^TMP($J,TMPA)) . W !,"^AUPNVINP("_TMPA_",0) has "_$G(^TMP($J,TMPA)) . S CNT=CNT+1 I CNT=0 W !!,"All data in ^AUPNVINP is acceptable for conversion",! D ^%ZISC Q ; SET ;-- this is where i set the nodes with the new pointers ;-- i don't set any nodes that are incomplete S DIR(0)="Y",DIR("A")="I will update the V HOSP pointers, continue: " D ^DIR G SET:$D(DIRUT) I Y<1 W !,"You must update V HOSP pointers, D SET^ADGGFL when ready" Q W !,"I am now repointing the V Hospitalization file " S REC=0 I $D(^TMP("VHOSP")) S (REC,AIEN)=$G(^TMP("VHOSP"))+1 ;IHS/DSD/ENM 05/04/99 NEXT LINE COPIED/MODIFIED ;S (ACNT,AIEN)=0 F S AIEN=$O(^AUPNVINP(AIEN)) Q:AIEN'?.N D S (ACNT,AIEN)=0 F S AIEN=$O(^AUPNVINP(AIEN)) Q:AIEN'=+AIEN D . Q:'$D(^AUPNVINP(AIEN)) . Q:$D(^TMP($J,AIEN)) . S ADT=$P(^AUPNVINP(AIEN,0),U,7) . S DIT=$P(^AUPNVINP(AIEN,0),U,6) . S NAT=$G(ADT(ADT)) . S NDT=$G(DIT(DIT)) . S $P(^AUPNVINP(AIEN,0),U,7)=NAT . S $P(^AUPNVINP(AIEN,0),U,6)=NDT . S ACNT=ACNT+1 . S REC=REC+1 . S ^TMP("VHOSP")=REC . I ACNT=50 W "." S ACNT=0 W !,"Conversion completed succsessfully, "_REC_" entries updated" Q ; END ;-- kill the variables and quit K FMNM,FMIEN,AIEN,ADT,DIT,NAT,NDT,DIE,DR,DA,ACNT,ENT,TMPA K ^TMP($J),^TMP("VHOSP") Q ; ADGSRVP1 ADGSRVP1 ; IHS/ADC/PDW/ENM - HSA-202 PRINT ; [ 08/05/1999 8:51 AM ] ;;5.0;ADMISSION/DISCHARGE/TRANSFER;**2,3**;MAR 25, 1999 ; N ND,LN S ND=$$ND,LN="",$P(LN,"-",40)="" P3 W !,DGLINE,!?16,"Part III",!?13,"Beds Available" W ?50,"Comments",!,LN,!,"STAFF UNITS",?21,"# of Beds",?32,"% Occup." ;W ?45,"ALOS: ",?60,"ADULT: ",$J(DGA(1,9)/DGLOS(1),1,2) ;adu alos W ?45,"ALOS: ",?60,"ADULT: ",$J($$LOS1(),1,2) W !,LN,?56,"PEDIATRIC: ",$J($$LOS2(),1,2) ;ped alos W !?58,"NEWBORN: ",$J($$LOS4(),1,2) ;nb alos W !,"MEDICAL (Adult)",?28,DGBED("AM") ;# med beds W !,"SURGICAL (Adult)",?28,DGBED("AS"),?27,"_____" ;# sur beds W ?45,"ADPL:",?60,"ADULT: ",$J(DGA(1,6)+DGA(3,6)/ND,1,2) ;adu adpl W !?15,"Subtotal",?28,DGBED("AM")+DGBED("AS"),?35,$$OA ;adu # & % W ?56,"PEDIATRIC: ",$J(DGA(2,6)/ND,1,2) ;ped adpl W !?58,"NEWBORN: ",$J(DGA(4,6)/ND,1,2) ;nb adpl W !,"MEDICAL (Pediatric)",?28,DGBED("PM") ;# m ped beds W !,"SURGICAL (Pediatric)",?28,DGBED("PS"),?27,"_____" ;# s ped beds W ?45,"1 DAY PATIENTS ADULT: ",DGA(1,10) ;1day W !?15,"Subtotal",?28,DGBED("PM")+DGBED("PS"),?35,$$OP ;ped # & % W ?56,"PEDIATRIC: ",DGA(2,10),!?58,"NEWBORN: ",DGA(4,10) ;1day W !,"OBSTETRIC",?28,DGBED("O"),?35,$$OO ;ob # & % W !,"TUBERCULOSIS",?28,DGBED("T"),?35,$$OT ;tb # & % W ?45,"ICU/SCU PATIENT DAYS: ",$$ICU W !,"ALCOHOL/SUBSTANCE ABUSE",?28,DGBED("AL"),?35,$$OL ;al # & % W ?49,"PCU PATIENT DAYS: ",$$PCU W !,"MENTAL HEALTH",?28,DGBED("MH"),?35,$$OM ;mh # & % W !,"ICU/SCU",?28,DGBED("I"),?35,$$OI ;icu # & % W !,"PCU",?28,DGBED("P"),?35,$$OU ;pcu # & % W ?48,"NON-BENEFICIARIES: ",!?27,"_____",?53,"# Discharged: ",DGCNT W !?18,"Total",?28,$$TOT,?48,"With total LOS of ",DGLOS," days" W !!,"NEWBORN",?28,DGBED("N"),?35,$$ON ;nb # & % W ?51,"% OF OCCUPANCY: ",$$OC,!,DGLINE W !,"Name of SUD",?35,"Signature Of SUD",?65,"Date" Q ; DAY ;;31 28 31 30 31 30 31 31 30 31 30 31 ; ND() ; -- # days in month N X S X=$P($P($T(DAY),";;",2)," ",$E(DGMON,4,5)) Q $S(X'=28:X,$E(DGMON,1,3)#4=0:29,1:X) ; OA() ; -- occup, adult Q:'(DGBED("AM")+DGBED("AS")) "" Q $J(DGA(1,6)/ND/(DGBED("AM")+DGBED("AS"))*100,3,0)_"%" ; OP() ; -- occup, ped Q:'(DGBED("PM")+DGBED("PS")) "" Q $J(DGA(2,6)/ND/(DGBED("PM")+DGBED("PS"))*100,3,0)_"%" ; OO() ; -- occup, ob Q:'DGBED("O") "" Q $J(DGA(3,6)/ND/DGBED("O")*100,3,0)_"%" ; OT() ; -- occup, tb Q:'DGBED("T") "" Q $J(DGA(5,6)/ND/DGBED("T")*100,3,0)_"%" ; OL() ; -- occup, al Q:'DGBED("AL") "" Q $J(DGA(6,6)/ND/DGBED("AL")*100,3,0)_"%" ; OM() ; -- occup, mh Q:'DGBED("MH") "" Q $J(DGA(7,6)/ND/DGBED("MH")*100,3,0)_"%" ; OI() ; -- occup, icu Q:'DGBED("I") "" Q $J($$ICU/ND/DGBED("I")*100,3,0)_"%" ; OU() ; -- occup, pcu Q:'DGBED("P") "" Q $J($$PCU/ND/DGBED("P")*100,3,0)_"%" ; ON() ; -- occup, nb Q:'DGBED("N") "" Q $J(DGA(4,6)/ND/DGBED("N")*100,3,0)_"%" ; OC() ; -- % of occupancy N X S X=DGX(6)/ND/$$TOT*100 Q:'X "0.00%" Q $J(X,3,0)_"%" ; ICU() ; -- icu patient days N X,D,T,E S (X,T)=0 F S X=$O(^DIC(42,X)) Q:'X D . Q:$P($G(^DIC(42,X,"IHS")),U)'="Y" . S D=DGMON,E=$E(DGMON,1,5)_"31" . F S D=$O(^ADGWD(X,1,D)) Q:'D!(D>E) D .. S T=T+$P($G(^ADGWD(+X,1,D,0)),U,2)+$P($G(^(0)),U,8) Q T ; PCU() ; -- pcu patient days N X,D,T,E S (X,T)=0 F S X=$O(^DIC(42,X)) Q:'X D . Q:$P($G(^DIC(42,X,"IHS")),U,5)'=1 . S D=DGMON,E=$E(DGMON,1,5)_"31" . F S D=$O(^ADGWD(X,1,D)) Q:'D!(D>E) D .. S T=T+$P($G(^ADGWD(+X,1,D,0)),U,2)+$P($G(^(0)),U,8) Q T ; LOS1() ; -- alos, adult ;IHS/DSD/ENM 08/04/99 DIV ERROR MOD ;Q (DGA(3,6)+DGA(1,6))/(DGA(1,3)+DGA(1,4)+DGA(3,3)+DGA(3,4)) Q (DGA(3,6)+DGA(1,6))/$S(DGA(1,3)+DGA(1,4)+DGA(3,3)+DGA(3,4)>0:DGA(1,3)+DGA(1,4)+DGA(3,3)+DGA(3,4),1:1) ; LOS2() ; -- alos, ped ;IHS/DSD/ENM 05/17/99 DIV ERROR MOD ;Q DGA(2,6)/(DGA(2,3)+DGA(2,4)) Q DGA(2,6)/$S(DGA(2,3)+DGA(2,4)>0:DGA(2,3)+DGA(2,4),1:1) ; LOS4() ; -- alos, ped ;IHS/DSD/ENM 05/17/99 DIV ERROR MOD ;Q DGA(4,6)/(DGA(4,3)+DGA(4,4)) Q DGA(4,6)/$S(DGA(4,3)+DGA(4,4)>0:DGA(4,3)+DGA(4,4),1:1) ; TOT() ; -- total # of beds ('nb) Q DGBED("AM")+DGBED("AS")+DGBED("PM")+DGBED("PS")+DGBED("O")+DGBED("I")+DGBED("T")+DGBED("AL")+DGBED("MH")+DGBED("P") ADGSVP1 ADGSVP1 ; IHS/ADC/PDW/ENM - HSA-202 PRINT ; [ 12/08/1999 4:17 PM ] ;;5.0;ADMISSION/DISCHARGE/TRANSFER;**2,3**;MAR 25, 1999 ; N ND,LN,X,Y,X1,X2 S X1=$E(DGEMON,1,5)_$$ND,X2=$E(DGSMON,1,5)_"01" D ^%DTC S ND=X+1 S LN="",$P(LN,"-",40)="" P3 W !,DGLINE,!?16,"Part III",!?13,"Beds Available" W ?50,"Comments",!,LN,!,"STAFF UNITS",?21,"# of Beds",?32,"% Occup." ;W ?45,"ALOS: ",?60,"ADULT: ",$J(DGA(1,9)/DGLOS(1),1,2) ;adu alos W ?45,"ALOS: ",?60,"ADULT: ",$J($$LOS1(),1,2) ;W !,LN,?56,"PEDIATRIC: ",$J(DGA(2,9)/DGLOS(2),1,2) ;ped alos W !,LN,?56,"PEDIATRIC: ",$J($$LOS2(),1,2) ;W !?58,"NEWBORN: ",$J(DGA(4,9)/DGLOS(4),1,2) ;nb alos W !?58,"NEWBORN: ",$J($$LOS4(),1,2) W !,"MEDICAL (Adult)",?28,DGBED("AM") ;# med beds W !,"SURGICAL (Adult)",?28,DGBED("AS"),?27,"_____" ;# sur beds W ?45,"ADPL:",?60,"ADULT: ",$J(DGA(1,6)+DGA(3,6)/ND,1,2) ;adu adpl W !?15,"Subtotal",?28,DGBED("AM")+DGBED("AS"),?35,$$OA ;adu # & % W ?56,"PEDIATRIC: ",$J(DGA(2,6)/ND,1,2) ;ped adpl W !?58,"NEWBORN: ",$J(DGA(4,6)/ND,1,2) ;nb adpl W !,"MEDICAL (Pediatric)",?28,DGBED("PM") ;# m ped beds W !,"SURGICAL (Pediatric)",?28,DGBED("PS"),?27,"_____" ;# s ped beds W ?45,"1 DAY PATIENTS ADULT: ",DGA(1,10) ;1day W !?15,"Subtotal",?28,DGBED("PM")+DGBED("PS"),?35,$$OP ;ped # & % W ?56,"PEDIATRIC: ",DGA(2,10),!?58,"NEWBORN: ",DGA(4,10) ;1day W !,"OBSTETRIC",?28,DGBED("O"),?35,$$OO ;ob # & % W !,"TUBERCULOSIS",?28,DGBED("T"),?35,$$OT ;tb # & % W ?49,"ICU PATIENT DAYS: ",$$ICU W !,"ALCOHOL/SUBSTANCE ABUSE",?28,DGBED("AL"),?35,$$OL ;al # & % W ?49,"PCU PATIENT DAYS: ",$$PCU W !,"MENTAL HEALTH",?28,DGBED("MH"),?35,$$OM ;mh # & % W !,"ICU/SCU",?28,DGBED("I"),?35,$$OI ;icu # & % W !,"PCU",?28,DGBED("P"),?35,$$OU ;pcu # & % W ?48,"NON-BENEFICIARIES: ",!?27,"_____",?53,"# Discharged: ",DGCNT W !?18,"Total",?28,$$TOT,?48,"With total LOS of ",DGLOS," days" W !!,"NEWBORN",?28,DGBED("N"),?35,$$ON ;nb # & % W ?51,"% OF OCCUPANCY: ",$$OC,!,DGLINE W !,"Name of SUD",?35,"Signature Of SUD",?65,"Date" Q ; DAY ;;31 28 31 30 31 30 31 31 30 31 30 31 ; ND() ; -- # days in month N X S X=$P($P($T(DAY),";;",2)," ",$E(DGEMON,4,5)) Q $S(X'=28:X,$E(DGEMON,1,3)#4=0:29,1:X) ; OA() ; -- occup, adult Q:'(DGBED("AM")+DGBED("AS")) "" Q $E($P(DGA(1,6)/ND/(DGBED("AM")+DGBED("AS")),".",2),1,2)_"%" ; OP() ; -- occup, ped Q:'(DGBED("PM")+DGBED("PS")) "" Q $E($P(DGA(2,6)/ND/(DGBED("PM")+DGBED("PS")),".",2),1,2)_"%" ; OO() ; -- occup, ob Q:'DGBED("O") "" Q $E($P(DGA(3,6)/ND/DGBED("O"),".",2),1,2)_"%" ; OT() ; -- occup, tb Q:'DGBED("T") "" Q $E($P(DGA(5,6)/ND/DGBED("T"),".",2),1,2)_"%" ; OL() ; -- occup, al Q:'DGBED("AL") "" Q $E($P(DGA(6,6)/ND/DGBED("AL"),".",2),1,2)_"%" ; OM() ; -- occup, mh Q:'DGBED("MH") "" Q $E($P(DGA(7,6)/ND/DGBED("MH"),".",2),1,2)_"%" ; OI() ; -- occup, icu Q:'DGBED("I") "" Q $E($P($$ICU/ND/DGBED("I"),".",2),1,2)_"%" ; OU() ; -- occup, pcu Q:'DGBED("P") "" Q $E($P($$PCU/ND/DGBED("P"),".",2),1,2)_"%" ; ON() ; -- occup, nb Q:'DGBED("N") "" Q $E($P(DGA(4,6)/ND/DGBED("N"),".",2),1,2)_"%" ; OC() ; -- % of occupancy N X S X=DGX(6)/ND/$$TOT Q:'X "0.00%" Q $E($P(X,".",2),1,2)_"%" ; ICU() ; -- icu patient days N X,D,T,E S (X,T)=0 F S X=$O(^DIC(42,X)) Q:'X D . Q:$P($G(^DIC(42,X,"IHS")),U)'="Y" . S D=DGSMON,E=$E(DGEMON,1,5)_"31" . F S D=$O(^ADGWD(X,1,D)) Q:'D!(D>E) D .. S T=T+$P($G(^ADGWD(+X,1,D,0)),U,2)+$P($G(^(0)),U,8) Q T ; PCU() ; -- pcu patient days N X,D,T,E S (X,T)=0 F S X=$O(^DIC(42,X)) Q:'X D . Q:$P($G(^DIC(42,X,"IHS")),U,5)'=1 . S D=DGSMON,E=$E(DGEMON,1,5)_"31" . F S D=$O(^ADGWD(X,1,D)) Q:'D!(D>E) D .. S T=T+$P($G(^ADGWD(+X,1,D,0)),U,2)+$P($G(^(0)),U,8) Q T ; LOS1() ; -- alos, adult ;IHS/DSD/ENM 12/08/99 DIV ERROR FIX ;Q (DGA(3,6)+DGA(1,6))/(DGA(1,3)+DGA(1,4)+DGA(3,3)+DGA(3,4)) Q (DGA(3,6)+DGA(1,6))/$S(DGA(1,3)+DGA(1,4)+DGA(3,3)+DGA(3,4)>0:DGA(1,3)+DGA(1,4)+DGA(3,3)+DGA(3,4),1:1) ; LOS2() ; -- alos, ped ;IHS/DSD/ENM 05/17/99 DIV ERROR FIX ;Q DGA(2,6)/(DGA(2,3)+DGA(2,4)) Q DGA(2,6)/$S(DGA(2,3)+DGA(2,4)>0:DGA(2,3)+DGA(2,4),1:1) ; LOS4() ; -- alos, ped ;IHS/DSD/ENM 05/17/99 DIV ERROR FIX ;Q DGA(4,6)/(DGA(4,3)+DGA(4,4)) Q DGA(4,6)/$S(DGA(4,3)+DGA(4,4)>0:DGA(4,3)+DGA(4,4),1:1) ; TOT() ; -- total # of beds ('nb) Q DGBED("AM")+DGBED("AS")+DGBED("PM")+DGBED("PS")+DGBED("O")+DGBED("I")+DGBED("T")+DGBED("AL")+DGBED("MH")+DGBED("P") ADGWMM2 ADGWMM2 ; IHS/ADC/PDW/ENM - WARD MEDICARE/MEDICAID PRINT ; [ 10/29/1999 1:31 PM ] ;;5.0;ADMISSION/DISCHARGE/TRANSFER;**3**;MAR 25, 1999 ; LDT ;EP; -- loop by disch date K ^TMP("ADGWMM",$J) NEW DGD,END,DGN S DGD=DGBD-.0001,END=DGED+.2400 F S DGD=$O(^DGPM("ATT3",DGD)) Q:'DGD!(DGD>END) D . S DGN=0 F S DGN=$O(^DGPM("ATT3",DGD,DGN)) Q:'DGN D .. S DFN=$P(^DGPM(DGN,0),U,3),DGPMCA=$P(^(0),U,14) .. D CHECK I DGMR="",DGMD="",DGPI="" Q .. S W=$$DWD .. S W=$$VAL^XBDIQ1(42,W,.01) I (DGW'=0),(W'=DGW) Q .. S ^TMP("ADGWMM",$J,W,DGD,DGN)=DFN_U_DGPMCA_U_DGMR_U_DGMD_U_DGPI_U_DGPINM ; D HDH,TMPLP Q ; TMPLP ; -- loop thru tmp file NEW X ;IHS/DSD/ENM NEXT LINE COPIED/MODIFIED ;S W=0 F S W=$O(^TMP("ADGWMM",$J,W)) Q:'W!(DGSTOP=U) D S W=0 F S W=$O(^TMP("ADGWMM",$J,W)) Q:W']""!(DGSTOP=U) D . S DGD=0 F S DGD=$O(^TMP("ADGWMM",$J,W,DGD)) Q:'DGD!(DGSTOP=U) D .. S DGN=0 .. F S DGN=$O(^TMP("ADGWMM",$J,W,DGD,DGN)) Q:'DGN!(DGSTOP=U) D ... S DGS=^TMP("ADGWMM",$J,W,DGD,DGN),DFN=+DGS ... D PRINT Q ; CHECK ; -- check for insurance types requested S (DGMD,DGMR,DGPI,DGPINM)="" I $D(^AUPNMCR("B",DFN)) S IFN=$O(^(DFN,0)) D MCR I $D(^AUPNMCD("B",DFN)) S IFN=$O(^(DFN,0)) D MCD I $D(^AUPNPRVT("B",DFN)) S IFN=$O(^(DFN,0)) D INS Q ; MCR ; -- medicare NEW ED,EED F ED=0:0 S ED=$O(^AUPNMCR(IFN,"11",ED)) Q:'ED D . S EED=$P(^AUPNMCR(IFN,11,ED,0),U,2),DGMR="" I EED>DT!('+EED) D .. S DGMR=$P(^AUPNMCR(IFN,0),U,3)_$P(^AUTTMCS($P(^(0),U,4),0),U) Q ; MCD ; -- medicaid NEW ED,EED F ED=0:0 S ED=$O(^AUPNMCD(IFN,"11",ED)) Q:'ED D . S EED=$P(^AUPNMCD(IFN,11,ED,0),U,2),DGMD="" . I EED>DT!('+EED) S DGMD=$P(^AUPNMCD(IFN,0),U,3) Q ; INS ; -- private insurance NEW ED,EED F ED=0:0 S ED=$O(^AUPNPRVT(IFN,"11",ED)) Q:'ED D . S EED=$P(^AUPNPRVT(IFN,11,ED,0),U,7),DGPI="" I EED>DT!('+EED) D .. S DGPI=$P(^AUPNPRVT(IFN,"11",ED,0),U,2) .. S DGPINM=$P(^AUTNINS($P(^AUPNPRVT(IFN,"11",ED,0),U,1),0),U,1) Q ; PRINT ; -- print NEW MR,MD,PV,PVN I $Y>(IOSL-6) D NEWPG Q:DGSTOP=U W !,$E($P(^DPT(DFN,0),U),1,20) ;name I $D(DUZ(2))&($D(^AUPNPAT(DFN,41,DUZ(2),0))) W ?22,$J($P(^(0),U,2),6) S DGPMCA=$P(DGS,U,2) ;corr admit S Y=+^DGPM(DGPMCA,0) X ^DD("DD") W ?32,Y ;admission date/time S Y=DGD X ^DD("DD") W ?50,Y ;dsch date/time W ?72,$E(W,1,5) W !?2,"Admit Dx: ",$P(^DGPM(DGPMCA,0),U,10) ;admitting Dx S MR=$P(DGS,U,3),MD=$P(DGS,U,4),PV=$P(DGS,U,5),PVN=$P(DGS,U,6) I MD W ?40,"MCAID #: ",MD I MR W ?61,"MCARE #: ",MR I PV W !?2,"Insurer: ",PVN," #",PV W ! Q ; HDH ; -- heading I DGPG>0!(IOST["C-") W @IOF D CONF^ADGUTIL(12) W !?24,"MEDICARE/MEDICAID/INSURANCE LIST" S DGPG=DGPG+1 S Y=DT X ^DD("DD") W ?69,Y W !?17,"for Discharge Dates: ",$$RANGE W !?2,"Patient Name",?23,"HRCN",?32,"Admit Date",?50,"Dsch Date" W ?72,"Ward" S LN="",$P(LN,"-",IOM)="" W !,LN Q ; NEWPG ; -- end of page control I IOST["C-" K DIR S DIR(0)="E" D ^DIR S DGSTOP=X Q:X=U D HDH Q ; RANGE() ; -- printable date range NEW X,Y,R S Y=DGBD X ^DD("DD") S R=Y_" to " S Y=DGED X ^DD("DD") S R=R_Y Q R ; DWD() ; -- find disch ward N X,Y,Z S Y=$G(^DGPM(+$P(^DGPM(DGPMCA,0),U,17),0)),Y=$$IDATE(+Y) S X=$O(^DGPM("ATID2",DFN,Y)) I X>$$IDATE(+^DGPM(DGPMCA,0)) S Z=DGPMCA I X]"",'$D(Z) S Z=$O(^DGPM("ATID2",DFN,X,0)) I X="" S Z=DGPMCA Q $P($G(^DGPM(+Z,0)),U,6) ; IDATE(X) ; -- inverse date Q (9999999.9999999-X) ASDAL ASDAL ; IHS/ADC/PDW/ENM - IHS APPT LIST CALLS ; [ 05/17/1999 1:51 PM ] ;;5.0;IHS SCHEDULING;**2**;MAR 25, 1999 ; -- subrtns called by SDAL and SDAL0 ; ASK ;EP; called to ask IHS questions K ASDQ S DIR(0)="Y",DIR("B")="YES",DIR("A")="INCLUDE WALK-INS" ;IHS added S DIR("?")="If you answer YES both walk-ins and chart requests will print" D ^DIR K DIR I $D(DIRUT) S ASDQ="" Q S ASDWI='Y ;I $$NOAMB,'$D(^XUSEC("SDZSUP",DUZ)) S ASDAMB=0 Q ;IHS/DSD/ENM 05/17/99 I $$NOAMB,'$D(^XUSEC("SDZSUP",DUZ)) S ASDAMB=0 G PHO ;IHS/DSD/ENM 05/17/99 S DIR(0)="Y",DIR("B")="NO",DIR("A")="INCLUDE WHO MADE APPT" D ^DIR K DIR I $D(DIRUT) S ASDQ="" Q S ASDAMB=Y PHO K ASDPH K DIR S DIR(0)="Y",DIR("B")="NO" ;IHS/DSD/ENM 05/17/99 PHO ADD S DIR("A")="INCLUDE PATIENT'S PHONE #" D ^DIR K DIR I $D(DIRUT) S ASDPH="" Q S ASDPH=Y Q ; HED ;EP; called by SDAL0 for IHS version of heading NEW X I SD1!(IOST["C-") W @IOF W !?16,$$CONF^ASDUT S (SDB,SD1)=1 I '$D(ASDT) S X=$$HTFM^XLFDT($H),ASDT=$$FMTE^XLFDT($E(X,1,12),"2P") W !,"APPOINTMENTS FOR ",$P(^SC(SC,0),U,1)," CLINIC ON ",SDPD W !?2,"TIME",?11,"PATIENT NAME",?33,"HRCN",?43,"DOB" W ?53," LAB@",?62,"X-RAY@",?74,"EKG@" W !?15,"OTHER INFORMATION",?55,"Printed: ",ASDT S SDXX="",$P(SDXX,"=",81)="" W !,SDXX Q ; TYPE ;EP; prints type of appt NEW X I $X>15 W !! I $P(^DPT(DFN,"S",SDT,0),U,7)=4 W ?12,"Walk-in/Chart Request" Q S X=$G(^SC(SC,"S",SDT,1,K,"C")) Q:X="" D TM^SDROUT0 W ?12,"Checked in at ",X Q ; AMB ;EP; prints appt made by if asked for NEW X,Y Q:'$G(ASDAMB) S X=$P($G(^SC(SC,"S",SDT,1,K,0)),U,6),Y=$P($G(^(0)),U,7) Q:X="" W !?15,"Made by ",$P($G(^VA(200,X,0)),U)," on ",$$FMTE^XLFDT(Y,"2D") I $P($G(^VA(200,X,.13)),U,2)]"" W ?53,"Phone: ",$P(^(.13),U,2) Q ; SHORT(SC,DATE) ;EP -- short list of appt times,lengths, & other info\ NEW T,P,N,END,C,Y,X S Y=DATE D DD^%DT W !!?15,"OTHER APPTS ALREADY SCHEDULED FOR ",Y W !?15,$$REPEAT^XLFSTR("=",46),! S END=DATE+.2400,T=DATE-.0001,C=0 F S T=$O(^SC(SC,"S",T)) Q:'T!(T>END) D . S P=0 F S P=$O(^SC(SC,"S",T,1,P)) Q:'P D .. S N=$G(^SC(SC,"S",T,1,P,0)) Q:N="" .. S Y=T D DD^%DT .. W !?2,$P(Y,"@",2),?10,$P(N,U,2)," MIN",?20,$E($P(N,U,4),1,59) .. S C=C+1 I C#10=0 K DIR S DIR(0)="E",DIR("A")="Return to continue" D ^DIR K DIR Q ; DOB() ;EP; -- returns date of birth N Y S Y=$P($G(^DPT(+$G(DFN),0)),U,3) X ^DD("DD") Q Y ; WI() ;EP; -- returns 1 if appt to be excluded from the list Q $S($G(ASDWI):$S($P(^DPT(DFN,"S",SDT,0),U,7)=4:1,1:0),1:0) ; NOAMB() ; -- returns 1 if restrict viewing of who made appt turned on Q $$VALI^XBDIQ1(40.8,$$DIV^ASDUT,9999999.12) ; PHONE() ;EP; -- returns patient's phone number I $G(ASDPH)'=1 Q "" Q $P($G(^DPT(DFN,.13)),U)_" " ASDREG ASDREG ; IHS/ADC/PDW/ENM - REG EDITS ALLOWED FROM SCHEDULING ; [ 08/19/1999 11:43 AM ] ;;5.0;IHS SCHEDULING;**3**;MAR 25, 1999 ;PEP; called by AMER1 to edit full registration ; S SDSTOP=$O(^DIC(19,"B","AGEDIT",0)) I SDSTOP'="",$P(^DIC(19,SDSTOP,0),"^",3)'="" K SDSTOP Q K SDSTOP ; K DIE("NO^"),SDQUIT ; EDITYP ; -- check user for edit type to use NEW ASDREG S ASDREG=$$VALI^XBDIQ1(40.8,$$DIV^ASDUT,9999999.09) I 'ASDREG D DISPLAY Q I $D(^XUSEC("SDZREGEDIT",DUZ)),ASDREG>1 D D END Q . D DISREG K DIR S DIR(0)="Y",DIR("B")="NO" . S DIR("A")="WANT TO EDIT REGISTRATION RECORD" D ^DIR K DIR . Q:Y=0 I Y'=1 S ASDQUIT="" Q . L +^AUPNPAT(DFN):3 I '$T D Q .. W !,*7,"PATIENT ENTRY LOCKED; TRY AGAIN SOON" . S DIE=9000001,DA=DFN,DR=".14" D ^DIE L -^AUPNPAT(DFN) . D ^AGVAR S X="AGEDIT" D HDR^AG,DISPAT . I $D(AGOPT(14)) D PATLK^AGEDIT ;IHS/DSD/ENM 08/19/99 . D ^XBCLS W !! D DISPAT W ! ; DISPLAY ;PEP; -- display address then ask to edit ; to call at PEP have DFN set and ASDREG=1 ; if you're sure user wants to edit, set ASDOK=1 NEW ASDR D ENP^XBDIQ1(2,DFN,".111;.114:.116;.131;.132","ASDR(") S X=$$VAL^XBDIQ1(9000001,DFN,.03) W !?5,$$FIELD(9000001,.03),": ",X W !!,ASDR(.111),!,ASDR(.114),", ",ASDR(.115)," ",ASDR(.116) W !,ASDR(.131)," (home) ",ASDR(.132)," (work)",!! I 'ASDREG!(ASDREG=3) D END Q I '$G(ASDOK) D I Y'=1 D END Q . NEW DIR S DIR(0)="Y0",DIR("B")="NO" . S DIR("A")="Does patient's address or phone # need to be updated" . D ^DIR ; L +^AUPNPAT(DFN):3 I '$T D D END Q . W !,*7,"PATIENT ENTRY LOCKED; TRY AGAIN SOON" ; ST ; -- mailing address-street S DR=.111 D PRESAVE,EDIT(2),POSTCK G END:$D(SDQUIT) ; CITY ; -- mailing address-city S DR=.114 D PRESAVE,EDIT(2),POSTCK I SDPOST'=SDPRE D NOTE G END:$D(DUOUT) ; STATE ; -- mailing address-state S DR=.115 D PRESAVE,EDIT(2),POSTCK G END:$D(SDQUIT) ; ZIP ; -- mailing address-zip S DR=.116 D PRESAVE,EDIT(2),POSTCK G END:$D(SDQUIT) ; HPH ; -- home phone number S DR=.131 D PRESAVE,EDIT(2),POSTCK G END:$D(SDQUIT) ; WPH ; -- work phone number S DR=.132 D PRESAVE,EDIT(2),POSTCK G END:$D(SDQUIT) W !! ; END ; -- eoj L -^AUPNPAT(DFN) K DA,DR,DIE,X,SDPOST,SDPRE,SDQUIT,ASDOK,ASDREG K AG,AGCHRT,AGLINE,AGOPT,AGPAT,AGQI,AGQT,AGSCRN,AGTP,AGUPDT Q ; ; PRESAVE ; -- SUBRTN to return before value of data S SDPRE=$$VAL^XBDIQ1(2,DFN,DR) Q ; POSTCK ; -- SUBRTN to return new value of data & set ^agpatch if needed NEW X S SDPOST=$$VAL^XBDIQ1(2,DFN,DR) I SDPOST=SDPRE Q S X="NOW" D ^%DT S ^AGPATCH(Y,DUZ(2),DFN)="" ;HL7 CALL S ^XTMP("AGHL7",DFN)=DFN Q ; EDIT(FILE) ; -- SUBRTN to set variables S DIE=FILE,DA=DFN W ! D ^DIE S:$D(Y) SDQUIT="" Q ; NOTE ; W !!?24,"Mailing address-city has changed." W !?9,"Please check to see if Community of Residence has changed also." W !!?20,"If Community of Residence has changed," W !?9,"have patient notify admitting - it affects eligibility.",! Q ; DISPAT ; displays patient name & identifiers NEW ASDX S ASDX=^DPT(DFN,0) W !!?3,$P(ASDX,U),?40,$P(ASDX,U,2) ;name,sex W ?45,$$FMTE^XLFDT($P(ASDX,U,3),2) ;dob W ?55,$P(ASDX,U,9) ;ssn W ?67,$$VAL^XBDIQ1(9999999.06,DUZ(2),.08) ;facility W ?69,$J($P(^AUPNPAT(DFN,41,DUZ(2),0),U,2),7) ;hrcn Q ; DISREG ; displays last reg update and add. info NEW X W !!?3,$$REPEAT^XLFSTR("*",70) S X=$$VAL^XBDIQ1(9000001,DFN,.03) W !?5,$$FIELD(9000001,.03),": ",X W !!?5,"Additional Registration Information:" S X=0 F S X=$O(^AUPNPAT(DFN,13,X)) Q:'X D . W !?7,^AUPNPAT(DFN,13,X,0) W !?3,$$REPEAT^XLFSTR("*",70),! Q ; FIELD(X,Y) ; -- returns name of field Q $P($G(^DD(X,Y,0)),U) DGPMV20 DGPMV20 ; IHS/ADC/PDW/ENM - DISPLAY DATES FOR SELECTION ; [ 05/19/1999 4:53 PM ] ;;5.0;ADMISSION/DISCHARGE/TRANSFER;**2**;MAR 25, 1999 ;;MAS VERSION 5.0; ;IHS/ANMC/RAM,LJF; ; -- changed ref to provider name to file 200 ; -- changed dx reference ; -- added ;EP to label ENEX ; W !!,"CHOOSE FROM:" F I=1:1:6 Q:'$D(^UTILITY("DGPMVN",$J,I)) D WR Q WR S DGX=$P(^UTILITY("DGPMVN",$J,I),"^",2,20),DGIFN=+^(I),Y=+DGX X ^DD("DD") W !,$J(I,2),"> ",Y I 'DGONE W ?27,$S('$D(^DG(405.1,+$P(DGX,"^",4),0)):"",$P(^(0),"^",7)]"":$P(^(0),"^",7),1:$E($P(^(0),"^",1),1,20)) I DGPMT=4!(DGPMT=5) S DGPMLD=$S($D(^DGPM(+DGIFN,"LD")):^("LD"),1:"") D @("W"_DGPMT) K DGIFN,DGX,DGPMLD Q W1 W ?50,"TO: ",$S($D(^DIC(42,+$P(DGX,"^",6),0)):$E($P(^(0),"^",1),1,17),1:"") I $D(^DG(405.4,+$P(DGX,"^",7),0)) W " [",$E($P(^(0),"^",1),1,10),"]" I $P(DGX,"^",18)=9 W !?23,"FROM: ",$S($D(^DIC(4,+$P(DGX,"^",5),0)):$P(^(0),"^",1),1:"") Q W2 Q:"^25^26^"[("^"_$P(DGX,"^",18)_"^") I "^43^45^"[("^"_$P(DGX,"^",18)_"^") W ?50,"TO: ",$S($D(^DIC(4,+$P(DGX,"^",5),0)):$E($P(^(0),"^",1),1,18),1:"") Q I "^1^2^3^"[("^"_$P(DGX,"^",18)_"^") W ?50,"RETURN: " S Y=$P(DGX,"^",13) X ^DD("DD") W Y Q W ?50,"TO: ",$S($D(^DIC(42,+$P(DGX,"^",6),0)):$E($P(^(0),"^",1),1,17),1:"") I $D(^DG(405.4,+$P(DGX,"^",7),0)) W " [",$E($P(^(0),"^",1),1,10),"]" Q ;IHS/DSD/ENM 05/19/99 MOD TO HANDLE VARIABLE POINTER FIELD W3 ;I $P(DGX,"^",18)=10 W ?50,"TO: ",$S($D(^DIC(4,+$P(DGX,"^",5),0)):$E($P(^(0),"^",1),1,18),1:"") I $P(DGX,"^",18)=10 W ?50,"TO: ",$S($P(DGX,"^",5)[";AUTT":$P(^AUTTVNDR(+$P(DGX,"^",5),0),"^"),$D(^DIC(4,+$P(DGX,"^",5),0)):$E($P(^(0),"^",1),1,18),1:"") Q W4 S X="" I $P(DGX,"^",18)=5 S X=$S($D(^DIC(42,+$P(DGX,"^",6),0)):^(0),1:"") I $P(DGX,"^",18)=6 S X=$S($D(^DIC(4,+$P(DGX,"^",5),0)):^(0),1:"") W ?55,"TO: ",$E($P(X,"^",1),1,20) I DGPMLD]"" W !?7,"REASON: ",$S($D(^DG(406.41,+DGPMLD,0)):$E($P(^(0),"^",1),1,20),1:""),?35,"COMMENTS: ",$P(DGPMLD,"^",2) Q W5 W:DGONE ?30 W:'DGONE !?7 W "DISPOSITION: ",$S($P(DGPMLD,"^",3)="a":"ADMITTED",$P(DGPMLD,"^",3)="d":"DISMISSED",1:"") Q W6 W:DGONE ?30 W:'DGONE !?7 W "SPECIALTY: ",$S($D(^DIC(45.7,+$P(DGX,"^",9),0)):$E($P(^(0),"^",1),1,18),1:"") ;W:DGONE !?7 W:'DGONE ?35 W "PROVIDER: ",$S($D(^DIC(16,+$P(DGX,"^",8),0)):$E($P(^(0),"^",1),1,15),1:"") ;IHS orig W:DGONE !?7 W:'DGONE ?35 W "PROVIDER: ",$S($D(^VA(200,+$P(DGX,"^",8),0)):$E($P(^(0),"^",1),1,15),1:"") ;IHS chgd ;S DGDX=$S($D(^DGPM(+DGIFN,"DX",1,0)):$E(^(0),1,30),1:"") I DGDX]"" W:DGONE ?37 W:'DGONE !?7 W "DX: ",DGDX ;IHS S DGDX=$P($G(^DGPM(+$P(^DGPM(+DGIFN,0),U,14),0)),U,10) I DGDX]"" W:DGONE ?37 W:'DGONE !?7 W "DX: ",DGDX ;IHS K DGDX Q ENEX ;EP; called by ^ADGPCAC0; IHS added ;CALLED FROM DGPMEX FOR EXTENDED BED CONTROL/EXTENDED PATIENT INQ S IOP="HOME" D ^%ZIS S DGFL=0 W @IOF,!!,"ADMISSION:" S DGX=DGPMAN,DGPMT=1,DGONE=0 D WEX S DGPMT=2 W !!,"TRANSFERS:" F I=+DGPMAN+.0000005:0 S I=$O(^DGPM("APCA",DFN,DGPMCA,I)) Q:'I S DGX=$O(^(I,0)) I $D(^DGPM(+DGX,0)) S DGX=^(0) Q:($P(DGX,"^",2)=3) D WEX Q:DGFL G Q:DGFL S DGONE=1 I $O(^DG(405.1,"AM",DGX,+$O(^DG(405.1,"AM",DGX,0)))) S DGONE=0 W !!,"TREATING SPECIALTY CHANGES:" S DGPMT=6 K ^UTILITY($J,"ATS") F I=0:0 S I=$O(^DGPM("ATS",DFN,DGPMCA,I)) Q:'I S J=$O(^(I,0)),DGIFN=$O(^(+J,0)) I $D(^DGPM(+DGIFN,0)) S ^UTILITY($J,"ATS",+^(0),DGIFN)=^(0) F I=0:0 S I=$O(^UTILITY($J,"ATS",I)) Q:'I S DGIFN=$O(^(I,0)),DGX=^(DGIFN) D WEX Q:DGFL I 'DGFL W !!,"DISCHARGE:" I $D(^DGPM(+$P(DGPMAN,"^",17),0)) S DGX=^(0),DGPMT=3,DGONE=0 D WEX Q K DIR,I,J,DGDIS,DGIFN,DGX,DUOUT,DTOUT Q WEX S Y=+DGX X ^DD("DD") W !?5,Y W:'DGONE ?27,$S('$D(^DG(405.1,+$P(DGX,"^",4),0)):"",$P(^(0),"^",7)]"":$P(^(0),"^",7),1:$E($P(^(0),"^",1),1,20)) D @("W"_DGPMT) I $S(DGPMT=1:0,DGPMT'=3:1,1:0),($Y>(IOSL-5)) S DIR(0)="E" D ^DIR S DGFL='Y S:$D(DTOUT) DGFL=2 I 'DGFL W @IOF Q DPTINIT DPTINIT ; ; 29-JUL-1996 [ 05/13/1999 2:44 PM ] ;;5.0;PATIENT FILE;**1**;MAY 04, 1999 ; K DIF,DIFQ,DIFQR,DIFQN,DIK,DDF,DDT,DTO,D0,DLAYGO,DIC,DIDUZ,DIR,DA,DIFROM,DFR,DTN,DIX,DZ,DIRUT,DTOUT,DUOUT S DIOVRD=1,U="^",DIFQ=0,DIFROM="5.0" W !,"This version (#5.0) of 'DPTINIT' was created on 12-DEC-1998" W !?9,"(at ANCH MED CTR, by VA FileMan V.21.0)",! I $D(^DD("VERSION")),^("VERSION")'<21 G GO ;W !,"FIRST, I'LL FRESHEN UP YOUR VA FILEMAN...." D N^DINIT I ^DD("VERSION")<21 W !,"but I need version 21 of the VA FileMan!" G Q GO ; ;IHS/DSD/ENM 05/03/99 NEXT LINE COPIED/MODIFIED I MASSITETYPE=1 W !,"I HAVE TO RUN AN ENVIRONMENT CHECK ROUTINE." D PKG,^DPTVPP Q:'$D(DIFQ) D NOW^%DTC S DIFROM("PRE")=% I MASSITETYPE=2 W !,"I HAVE TO RUN AN ENVIRONMENT CHECK ROUTINE." D PKG,^DPTZZ,NOW^%DTC S DIFROM("PRE")=% EN ; ENTER HERE TO BYPASS THE PRE-INIT PROGRAM S DIFQ=0 K DIRUT,DTOUT,DUOUT F DIFRIR=1:1:1 S DIFRRTN="^DPTINIT"_$E("5",DIFRIR) D @DIFRRTN W:1 !,"I AM GOING TO SET UP THE FOLLOWING FILES:" F I=1:2:8 S DIF(I)=^UTILITY("DIF",$J,I) D 1 G Q:DIFQ!$D(DIRUT) K DIF(I) S DIFROM="5.0" D PKG:'$D(DIFROM(0)),^DPTINIT1 G Q:'$D(DIFQ) S DIK(0)="AB" F DIF=1:2:8 S %=^UTILITY("DIF",$J,DIF),DIK=$P(%,";",5),N=$P(%,";",3),D=$P(%,";",4)_U_N D D K DIFQ(N) K DIFQR D ^DPTINIT2,^DPTINIT3 L S DUZ=DIDUZ W:1 !,"NO"_$P("TE THAT FILE",U,DSEC)_" SECURITY-CODE PROTECTION HAS BEEN MADE" D ^DPTVPT,NOW^%DTC S DIFROM("INIT")=% I DIFROM F DIF=1:2:8 S %=^UTILITY("DIF",$J,DIF),N=+$P(%,";",3) I N,$P(%,";",8)="y" S ^DD(N,0,"VR")=DIFROM I DIFROM(0)>0 F %="PRE","INI","INIT" S:$D(DIFROM(%)) $P(^DIC(9.4,DIFROM(0),%),U,2)=DIFROM(%) I $G(DIFQN) S $P(^(0),U,3,4)=$P(DIFQN,U,2)_U_($P(^DIC(0),U,4)+DIFQN) K DIFQN I DIFROM,$D(^%ZTSK) S X="DPTINIS" X ^%ZOSF("TEST") D:$T PAC^DPTINIS($T(IXF),.DIFROM) S:DIFROM(0)>0 ^DIC(9.4,DIFROM(0),"VERSION")=DIFROM G Q^DIFROM0 D S:$D(^DIC(+N,0))[0 ^(0)=D S X=$D(@(DIK_"0)")),^(0)=D_U_$S(X#2:$P(^(0),U,3,9),1:U) S DIFQR=DIFQR(+N) I ^DD("VERSION")>17.5,$D(^DD(+N,0,"DIK"))#2 S X=^("DIK"),Y=+N,DMAX=^DD("ROU") D EN^DIKZ I DIFQR D IXALL^DIK:$O(@(DIK_"0)")) W "." Q R G REP^DPTINIT2 ; 1 S N=+$P(DIF(I),";",3),DIF=$P(DIF(I),";",4),S=$P(DIF(I),";",5) W !!?3,N,?13,DIF,$P(" (Partial Definition)",U,$P(DIF(I),";",6)),$P(" (including data)",U,$P(DIF(I),";",13)="y") S Z=$S($D(^DIC(N,0))#2:^(0),1:"") I Z="" S DIFQ(N)=1,DIFQN=$G(DIFQN)+1_U_N G S I $L($P(Z,DIF)) W $C(7),!,"*BUT YOU ALREADY HAVE '",$P(Z,U),"' AS FILE #",N,"!" D R Q:DIFQ G S:$D(DIFKEP(N)),1 S DIFQ(N)=$P(DIF(I),";",7)'="n" I $L(Z) W $C(7),!,"Note: You already have the '",$P(Z,U),"' File." S DIFQ(0)=1 S %=$E(^UTILITY("DIF",$J,I+1),4,245) I %]"" X % S DIFQ(N)=$T W:'$T !,"Screen on this Data Dictionary did not pass--DD will not be installed!" G S I $L(Z),$P(DIF(I),";",10)="y" S DIR("A")="Shall I write over the existing Data Definition",DIR("??")="^D DD^DIFROMH1",DIR("B")="YES",DIR(0)="Y" D ^DIR S DIFQ(N)=Y S S DIFQR(N)=0 Q:$P(DIF(I),";",13)'="y"!$D(DIRUT) I $P(DIF(I),";",15)="y",$O(@(S_"0)"))>0 S DIF=$P(DIF(I),";",14)="o",DIR("A")="Want my data "_$P("merged with^to overwrite",U,DIF+1)_" yours",DIR("??")="^D DTA^DIFROMH1",DIR(0)="Y" D ^DIR S DIFQR(N)=$S('Y:Y,1:Y+DIF) Q S %=$P(DIF(I),";",14)="o" W !,$C(7),"I will ",$P("MERGE^OVERWRITE",U,%+1)," your data with mine." S DIFQR(N)=%+1 Q Q W $C(7),!!,"NO UPDATING HAS OCCURRED!" G Q^DIFROM0 ; PKG S X=$P($T(IXF),";",3),DIC="^DIC(9.4,",DIC(0)="",DIC("S")="I $P(^(0),U,2)="""_$P(X,U,2)_"""",X=$P(X,U) D ^DIC S DIFROM(0)=+Y K DIC Q ; IXF ;;PATIENT FILE^DPT;0 DPTZZ DPTZZ ; IHS/DSD/ENM - OUTPATIENT ENVIRONMENT CHECK [ 05/13/1999 2:45 PM ] ;;5.0;PATIENT FILE;**1**;MAY 13, 1999 EP ;ENTRY POINT S DGVCUR=4.2,DGVREQ=4.2,DGVREL=5,DGVNEW=5,SDVCUR=3.62 Q MASETUP1 MASETUP1 ;IHS/ADC/PDW/ENM Routine to install MAS modelling KIDS [ 05/13/1999 2:44 PM ] ;;5.0;MAS INSTALLATION;**1**;MAY 04, 1999 ;IHS/DSD/ENM This setup program is a copy of MASSETUP. ;It was created to do a different environment check for ;outpatient only sites! ;searhc/maw added call to POST for post processing Q EN ;EP START W !,?10,"Welcome to the MAS Installation Shell",! W !,?10,"Doing ^XUP ... >> DO NOT PICK AN OPTION !! <<",! D ^XUP W !,?10,"Doing P^DI ... >> DO NOT PICK AN OPTION, Press 'Return' !! <<",! ;IHS/DSD/ENM 05/06/99 D Q^DI ;IHS/DSD/ENM 05/06/99 W !! I $G(DUZ)'>0 W !,"Not a valid user ... Stopping Installation" Q S MASSITETYPE=2 ;IHS/DSD/ENM 05/03/99 S X="ADMISSION/DISCHARGE/TRANSFER" S DIC=$$DIC^XBDIQ1(9.4),DIC(0)="MX" D ^DIC I Y'>0 W !,"Possible Problem with ADT package not found in Package File" S XBDGDA=+Y S X="IHS SCHEDULING" S DIC=$$DIC^XBDIQ1(9.4),DIC(0)="MX" D ^DIC I Y'>0 W !,"Possible Problem with IHS SCHEDULING package not found in Package File" S XBSDDA=+Y S XBDGVER=$$VAL^XBDIQ1(9.4,XBDGDA,13) S XBSDVER=$$VAL^XBDIQ1(9.4,XBSDDA,13) W !!,?5,"Package",?40,"Current Version" W !!,?5,"ADMISSION/DISCHARGE/TRANSFER",?40,XBDGVER W !,?5,"IHS SCHEDULING",?40,XBSDVER I +XBDGVER I XBDGVER'>4.1 W !!,"Stopping Installation ... ADT not 4.2 or later" G EXIT ;====>> ;IHS/DSD/ENM 07/24/98 VERSION #CHANGED I '$D(^XTMP("MAS_INSTAL")) D SET STAT ;EP scan the footprint and process W !!,?10,"MAS Installation Shell Tracking" W !,?5,"Step",?15,"Function",?35,"Completed" S MASNEXT=0,MASLAST=0 S I=0 F S I=$O(^XTMP("MAS_INSTAL",I)) Q:I'>0 D WRITE S MASNEXT=MASLAST+1 ; if a previous installation was started MASNEXT = the nextstep ; W !!,"The next step is step ",MASNEXT,! I MASNEXT=1 G MAS2 W !,?5,"C -Continue E -Exit S -Start Over R -Rerun Last Step",! K DIR S DIR(0)="SB^C:Continue;E:Exit;S:Start Over;R:Rerun Last Step" D ^DIR I Y="E" W !!,"EXITING",! G EXIT I Y="S" W !!,"Starting Over",! K ^XTMP("MAS_INSTAL") G EN I Y="R" W !!,"Rerun Last Step" S MASNEXT=MASNEXT-1 G MAS2 I Y'="C" G EXIT MAS2 ;EP picking up where the instal left off S MAS2=$O(^XTMP("MAS_INSTAL",MASNEXT,0)),MAS3=$O(^(MAS2,0)) ; branch to the next step in MAS3 G @MAS3 ;====>> @MAS3 ; ; WRITE ;EP S MAS2=$O(^XTMP("MAS_INSTAL",I,0)),MAS3=$O(^(MAS2,0)) W !?5,I,?15,MAS2 S MAST=$G(^XTMP("MAS_INSTAL",I)) I 'MAST W ?35,"NO" Q E W ?35,"YES" I MAST S MASLAST=I Q ; **** entry to the entry points is controlled by STAT DGYPINIT ;EP ; S MAS1="MAS_INSTAL",MASI=1,MAS2="D ^DGYPINIT",MAS3="DGYPINIT" S ^XTMP(MAS1,MASI,MAS2,MAS3)=0 S DIR(0)="E",DIR("A")=" to Continue ""^"" to Exit" D ^DIR I Y'=1 G EXIT W @IOF,?10,MAS2 W !,"Ready to run ^DGYPINIT .. answer yes to all questions," S DIR(0)="E",DIR("A")=" to Continue ""^"" to Exit" D ^DIR I Y'=1 G EXIT ;====>> D ^DGYPINIT S ^XTMP(MAS1,MASI)=1 ; ORINIT ;EP ; S MAS1="MAS_INSTAL",MASI=2,MAS2="D ^ORINIT",MAS3="ORINIT" S ^XTMP(MAS1,MASI,MAS2,MAS3)=0 S DIR(0)="E",DIR("A")=" to Continue ""^"" to Exit" D ^DIR I Y'=1 G EXIT ;====>> W @IOF,?10,MAS2 W !,"Ready to run ^ORINIT .. answer yes to all questions (5+ MIN)," S DIR(0)="E",DIR("A")=" to Continue ""^"" to Exit" D ^DIR I Y'=1 G EXIT ;====>> D ^ORINIT S ^XTMP(MAS1,MASI)=1 ; DPTINIT ;EP ; S MAS1="MAS_INSTAL",MASI=3,MAS2="D ^DPTINIT",MAS3="DPTINIT" S ^XTMP(MAS1,MASI,MAS2,MAS3)=0 S DIR(0)="E",DIR("A")=" to Continue ""^"" to Exit" D ^DIR I Y'=1 G EXIT ;====>> W @IOF,?10,MAS2 W !,"Ready to run ^DPTINIT .. answer yes to all questions (3+ MIN)," S DIR(0)="E",DIR("A")=" to Continue ""^"" to Exit" D ^DIR I Y'=1 G EXIT ;====>> D ^DPTINIT S ^XTMP(MAS1,MASI)=1 ; DGINIT ;EP ; S MAS1="MAS_INSTAL",MASI=4,MAS2="D ^DGINIT",MAS3="DGINIT" S ^XTMP(MAS1,MASI,MAS2,MAS3)=0 S DIR(0)="E",DIR("A")=" to Continue ""^"" to Exit" D ^DIR I Y'=1 G EXIT ;====>> W @IOF,?10,MAS2 W !,"Ready to run ^DGINIT .. answer yes to all questions (>>1 & 1/2 HOURS<<)," S DIR(0)="E",DIR("A")=" to Continue ""^"" to Exit" D ^DIR I Y'=1 G EXIT ;====>> D ^DGINIT S ^XTMP(MAS1,MASI)=1 ; DG5INIT ;EP ; S MAS1="MAS_INSTAL",MASI=5,MAS2="D ^DG5INIT",MAS3="DG5INIT" S ^XTMP(MAS1,MASI,MAS2,MAS3)=0 S DIR(0)="E",DIR("A")=" to Continue ""^"" to Exit" D ^DIR I Y'=1 G EXIT ;====>> W @IOF,?10,MAS2 W !,"Ready to run ^DG5INIT .. answer yes to all questions (30+ MIN)," S DIR(0)="E",DIR("A")=" to Continue ""^"" to Exit" D ^DIR I Y'=1 G EXIT ;====>> D ^DG5INIT S ^XTMP(MAS1,MASI)=1 ; SDINIT ;EP ; S MAS1="MAS_INSTAL",MASI=6,MAS2="D ^SDINIT",MAS3="SDINIT",MAS3="SDINIT" S ^XTMP(MAS1,MASI,MAS2,MAS3)=0 S DIR(0)="E",DIR("A")=" to Continue ""^"" to Exit" D ^DIR I Y'=1 G EXIT ;====>> W @IOF,?10,MAS2 W !,"Ready to run ^SDINIT .. answer yes to all questions (40+ MIN)," I '+$G(XBSDVER) D I Y'>1 G SKIPSD ;====>> . W !,"Scheduling is not previously installed on your system",! . S DIR(0)="E",DIR("A")="Enter ""^"" to Skip SDINIT" D ^DIR S DIR(0)="E",DIR("A")=" to Continue ""^"" to Exit" D ^DIR I Y'=1 G EXIT ;====>> D ^SDINIT SKIPSD ;EP skipping SDINIT S ^XTMP(MAS1,MASI)=1 ; DGPM5P1 ;EP ; S MAS1="MAS_INSTAL",MASI=7,MAS2="D ^DGPM5 part 1",MAS3="DGPM5P1" S ^XTMP(MAS1,MASI,MAS2,MAS3)=0 S DIR(0)="E",DIR("A")=" to Continue ""^"" to Exit" D ^DIR I Y'=1 G EXIT ;====>> W @IOF,?10,MAS2 W !,"Ready to run ^DGPM5 part 1 .." S DIR(0)="E",DIR("A")=" to Continue ""^"" to Exit" D ^DIR I Y'=1 G EXIT ;====>> D ^DGPM5 S ^XTMP(MAS1,MASI)=1 ; DGPM5P2 ;EP ; S MAS1="MAS_INSTAL",MASI=8,MAS2="D ^DGPM5 part 2",MAS3="DGPM5P2" S ^XTMP(MAS1,MASI,MAS2,MAS3)=0 S DIR(0)="E",DIR("A")=" to Continue ""^"" to Exit" D ^DIR I Y'=1 G EXIT ;====>> W @IOF,?10,MAS2 W !,"Ready to run ^DGPM5 part 2 .." S DIR(0)="E",DIR("A")=" to Continue ""^"" to Exit" D ^DIR I Y'=1 G EXIT ;====>> D ^DGPM5 S ^XTMP(MAS1,MASI)=1 S DIR(0)="E",DIR("A")=" to Continue ""^"" to Exit" D ^DIR I Y'=1 G EXIT ;====>> ; ; POST ;EP ;searhc/maw this should be called last, it will convert the pointers ;in the V Hospitalization file, patient movement and provider ;pointers S MAS1="MAS_INSTAL",MASI=8,MAS2="POST^MASSETUP",MAS3="POST" S ^XTMP(MAS1,MASI,MAS2,MAS3)=0 W @IOF,?10,MAS2 W !,"Ready to run MAS Post Init Processing .." S DIR(0)="E",DIR("A")=" to Continue ""^"" to Exit" D ^DIR I Y'=1 G EXIT D ^ADGGFL S DIR(0)="E",DIR("A")=" to Continue ""^"" to Exit" I Y'=1 G EXIT D ^ADGCP S ^XTMP(MAS1,MASI)=1 S DIR(0)="E",DIR("A")=" to Continue ""^"" to Exit" I Y'=1 G EXIT ; DELINI ;EP delete routines S MAS1="MAS_INSTAL",MASI=9,MAS2="Delete Inits",MAS3="DELINI" S ^XTMP(MAS1,MASI,MAS2,MAS3)=0 S DIR(0)="E",DIR("A")=" to Continue ""^"" to Exit" D ^DIR I Y'=1 G EXIT ;====>> W @IOF,?10,MAS2 W !,"Ready to Delete Inits .." S DIR(0)="E",DIR("A")=" to Continue ""^"" to Exit" D ^DIR I Y'=1 G EXIT ;====>> K DIR S DIR(0)="Y" K ^XTMP("ZIBRSEL",$J) S Z=$$RSEL^ZIBRSEL("DGINI-DGINIZZ") D DEL S Z=$$RSEL^ZIBRSEL("DGONI-DGONIZZ") D DEL S Z=$$RSEL^ZIBRSEL("DG5INI-DG5INIZZ") D DEL S Z=$$RSEL^ZIBRSEL("DGYP-DGYPZZZ") D DEL S Z=$$RSEL^ZIBRSEL("SDINI-SDINIZZZ") D DEL S Z=$$RSEL^ZIBRSEL("SDONI-SDONIZZZ") D DEL S Z=$$RSEL^ZIBRSEL("ORINI-ORINIZZZ") D DEL S Z=$$RSEL^ZIBRSEL("DPTIN-DPTINZZZ") D DEL K ^XTMP("ZIBRSEL",$J) S ^XTMP(MAS1,MASI)=1 ; FINISH ;EP W !,"MAS VERSION 5.0 Installation has been completed" W !,"Proceed with step 11 of the installation instructions" S DIR(0)="E",DIR("A")="" D ^DIR ; EXIT ;EP D EN^XBVK("MAS"),EN^XBVK("XB") Q DEL ;EP W !!,Z S X="" F I=1:1 S X=$O(^TMP("ZIBRSEL",$J,X)) Q:X="" D . W ?(10*I),X . X ^%ZOSF("DEL") . I I=7 W ! S I=0 Q SET ;EP S X1=DT,X2=30 D C^%DTC S MAS1="MAS_INSTAL",MASI=1,MAS2="D ^DGYPINIT",MAS3="DGYPINIT" S ^XTMP(MAS1,MASI,MAS2,MAS3)=0 S MAS1="MAS_INSTAL",MASI=2,MAS2="D ^ORINIT",MAS3="ORINIT" S ^XTMP(MAS1,MASI,MAS2,MAS3)=0 S MAS1="MAS_INSTAL",MASI=3,MAS2="D ^DPTINIT",MAS3="DPTINIT" S ^XTMP(MAS1,MASI,MAS2,MAS3)=0 S MAS1="MAS_INSTAL",MASI=4,MAS2="D ^DGINIT",MAS3="DGINIT" S ^XTMP(MAS1,MASI,MAS2,MAS3)=0 S MAS1="MAS_INSTAL",MASI=5,MAS2="D ^DG5INIT",MAS3="DG5INIT" S ^XTMP(MAS1,MASI,MAS2,MAS3)=0 S MAS1="MAS_INSTAL",MASI=6,MAS2="D ^SDINIT",MAS3="SDINIT",MAS3="SDINIT" S ^XTMP(MAS1,MASI,MAS2,MAS3)=0 S MAS1="MAS_INSTAL",MASI=7,MAS2="D ^DGPM5 part 1",MAS3="DGPM5P1" S ^XTMP(MAS1,MASI,MAS2,MAS3)=0 S MAS1="MAS_INSTAL",MASI=8,MAS2="D ^DGPM5 part 2",MAS3="DGPM5P2" S ^XTMP(MAS1,MASI,MAS2,MAS3)=0 S MAS1="MAS_INSTAL",MASI=9,MAS2="D POST^MASSETUP",MAS3="POST" S ^XTMP(MAS1,MASI,MAS2,MAS3)=0 S MAS1="MAS_INSTAL",MASI=10,MAS2="Delete Inits",MAS3="DELINI" S ^XTMP(MAS1,MASI,MAS2,MAS3)=0 Q MASSETUP MASSETUP ;IHS/ADC/PDW/ENM Routine to install MAS modelling KIDS [ 05/13/1999 2:43 PM ] ;;5.0;MAS INSTALLATION;**1**;MAY 04, 1999 ;searhc/maw added call to POST for post processing Q EN ;EP START W !,?10,"Welcome to the MAS Installation Shell",! W !,?10,"Doing ^XUP ... >> DO NOT PICK AN OPTION !! <<",! D ^XUP W !,?10,"Doing P^DI ... >> DO NOT PICK AN OPTION, Press 'Return' !! <<",! ;IHS/DSD/ENM 05/06/99 D Q^DI ;IHS/DSD/ENM 05/06/99 W !! I $G(DUZ)'>0 W !,"Not a valid user ... Stopping Installation" Q S MASSITETYPE=1 ;IHS/DSD/ENM 05/03/99 S X="ADMISSION/DISCHARGE/TRANSFER" S DIC=$$DIC^XBDIQ1(9.4),DIC(0)="MX" D ^DIC I Y'>0 W !,"Possible Problem with ADT package not found in Package File" S XBDGDA=+Y S X="IHS SCHEDULING" S DIC=$$DIC^XBDIQ1(9.4),DIC(0)="MX" D ^DIC I Y'>0 W !,"Possible Problem with IHS SCHEDULING package not found in Package File" S XBSDDA=+Y S XBDGVER=$$VAL^XBDIQ1(9.4,XBDGDA,13) S XBSDVER=$$VAL^XBDIQ1(9.4,XBSDDA,13) W !!,?5,"Package",?40,"Current Version" W !!,?5,"ADMISSION/DISCHARGE/TRANSFER",?40,XBDGVER W !,?5,"IHS SCHEDULING",?40,XBSDVER I +XBDGVER I XBDGVER'>4.1 W !!,"Stopping Installation ... ADT not 4.2 or later" G EXIT ;====>> ;IHS/DSD/ENM 07/24/98 VERSION #CHANGED I '$D(^XTMP("MAS_INSTAL")) D SET STAT ;EP scan the footprint and process W !!,?10,"MAS Installation Shell Tracking" W !,?5,"Step",?15,"Function",?35,"Completed" S MASNEXT=0,MASLAST=0 S I=0 F S I=$O(^XTMP("MAS_INSTAL",I)) Q:I'>0 D WRITE S MASNEXT=MASLAST+1 ; if a previous installation was started MASNEXT = the nextstep ; W !!,"The next step is step ",MASNEXT,! I MASNEXT=1 G MAS2 W !,?5,"C -Continue E -Exit S -Start Over R -Rerun Last Step",! K DIR S DIR(0)="SB^C:Continue;E:Exit;S:Start Over;R:Rerun Last Step" D ^DIR I Y="E" W !!,"EXITING",! G EXIT I Y="S" W !!,"Starting Over",! K ^XTMP("MAS_INSTAL") G EN I Y="R" W !!,"Rerun Last Step" S MASNEXT=MASNEXT-1 G MAS2 I Y'="C" G EXIT MAS2 ;EP picking up where the instal left off S MAS2=$O(^XTMP("MAS_INSTAL",MASNEXT,0)),MAS3=$O(^(MAS2,0)) ; branch to the next step in MAS3 G @MAS3 ;====>> @MAS3 ; ; WRITE ;EP S MAS2=$O(^XTMP("MAS_INSTAL",I,0)),MAS3=$O(^(MAS2,0)) W !?5,I,?15,MAS2 S MAST=$G(^XTMP("MAS_INSTAL",I)) I 'MAST W ?35,"NO" Q E W ?35,"YES" I MAST S MASLAST=I Q ; **** entry to the entry points is controlled by STAT DGYPINIT ;EP ; S MAS1="MAS_INSTAL",MASI=1,MAS2="D ^DGYPINIT",MAS3="DGYPINIT" S ^XTMP(MAS1,MASI,MAS2,MAS3)=0 S DIR(0)="E",DIR("A")=" to Continue ""^"" to Exit" D ^DIR I Y'=1 G EXIT W @IOF,?10,MAS2 W !,"Ready to run ^DGYPINIT .. answer yes to all questions," S DIR(0)="E",DIR("A")=" to Continue ""^"" to Exit" D ^DIR I Y'=1 G EXIT ;====>> D ^DGYPINIT S ^XTMP(MAS1,MASI)=1 ; ORINIT ;EP ; S MAS1="MAS_INSTAL",MASI=2,MAS2="D ^ORINIT",MAS3="ORINIT" S ^XTMP(MAS1,MASI,MAS2,MAS3)=0 S DIR(0)="E",DIR("A")=" to Continue ""^"" to Exit" D ^DIR I Y'=1 G EXIT ;====>> W @IOF,?10,MAS2 W !,"Ready to run ^ORINIT .. answer yes to all questions (5+ MIN)," S DIR(0)="E",DIR("A")=" to Continue ""^"" to Exit" D ^DIR I Y'=1 G EXIT ;====>> D ^ORINIT S ^XTMP(MAS1,MASI)=1 ; DPTINIT ;EP ; S MAS1="MAS_INSTAL",MASI=3,MAS2="D ^DPTINIT",MAS3="DPTINIT" S ^XTMP(MAS1,MASI,MAS2,MAS3)=0 S DIR(0)="E",DIR("A")=" to Continue ""^"" to Exit" D ^DIR I Y'=1 G EXIT ;====>> W @IOF,?10,MAS2 W !,"Ready to run ^DPTINIT .. answer yes to all questions (3+ MIN)," S DIR(0)="E",DIR("A")=" to Continue ""^"" to Exit" D ^DIR I Y'=1 G EXIT ;====>> D ^DPTINIT S ^XTMP(MAS1,MASI)=1 ; DGINIT ;EP ; S MAS1="MAS_INSTAL",MASI=4,MAS2="D ^DGINIT",MAS3="DGINIT" S ^XTMP(MAS1,MASI,MAS2,MAS3)=0 S DIR(0)="E",DIR("A")=" to Continue ""^"" to Exit" D ^DIR I Y'=1 G EXIT ;====>> W @IOF,?10,MAS2 W !,"Ready to run ^DGINIT .. answer yes to all questions (>>1 & 1/2 HOURS<<)," S DIR(0)="E",DIR("A")=" to Continue ""^"" to Exit" D ^DIR I Y'=1 G EXIT ;====>> D ^DGINIT S ^XTMP(MAS1,MASI)=1 ; DG5INIT ;EP ; S MAS1="MAS_INSTAL",MASI=5,MAS2="D ^DG5INIT",MAS3="DG5INIT" S ^XTMP(MAS1,MASI,MAS2,MAS3)=0 S DIR(0)="E",DIR("A")=" to Continue ""^"" to Exit" D ^DIR I Y'=1 G EXIT ;====>> W @IOF,?10,MAS2 W !,"Ready to run ^DG5INIT .. answer yes to all questions (30+ MIN)," S DIR(0)="E",DIR("A")=" to Continue ""^"" to Exit" D ^DIR I Y'=1 G EXIT ;====>> D ^DG5INIT S ^XTMP(MAS1,MASI)=1 ; SDINIT ;EP ; S MAS1="MAS_INSTAL",MASI=6,MAS2="D ^SDINIT",MAS3="SDINIT",MAS3="SDINIT" S ^XTMP(MAS1,MASI,MAS2,MAS3)=0 S DIR(0)="E",DIR("A")=" to Continue ""^"" to Exit" D ^DIR I Y'=1 G EXIT ;====>> W @IOF,?10,MAS2 W !,"Ready to run ^SDINIT .. answer yes to all questions (40+ MIN)," I '+$G(XBSDVER) D I Y'>1 G SKIPSD ;====>> . W !,"Scheduling is not previously installed on your system",! . S DIR(0)="E",DIR("A")="Enter ""^"" to Skip SDINIT" D ^DIR S DIR(0)="E",DIR("A")=" to Continue ""^"" to Exit" D ^DIR I Y'=1 G EXIT ;====>> D ^SDINIT SKIPSD ;EP skipping SDINIT S ^XTMP(MAS1,MASI)=1 ; DGPM5P1 ;EP ; S MAS1="MAS_INSTAL",MASI=7,MAS2="D ^DGPM5 part 1",MAS3="DGPM5P1" S ^XTMP(MAS1,MASI,MAS2,MAS3)=0 S DIR(0)="E",DIR("A")=" to Continue ""^"" to Exit" D ^DIR I Y'=1 G EXIT ;====>> W @IOF,?10,MAS2 W !,"Ready to run ^DGPM5 part 1 .." S DIR(0)="E",DIR("A")=" to Continue ""^"" to Exit" D ^DIR I Y'=1 G EXIT ;====>> D ^DGPM5 S ^XTMP(MAS1,MASI)=1 ; DGPM5P2 ;EP ; S MAS1="MAS_INSTAL",MASI=8,MAS2="D ^DGPM5 part 2",MAS3="DGPM5P2" S ^XTMP(MAS1,MASI,MAS2,MAS3)=0 S DIR(0)="E",DIR("A")=" to Continue ""^"" to Exit" D ^DIR I Y'=1 G EXIT ;====>> W @IOF,?10,MAS2 W !,"Ready to run ^DGPM5 part 2 .." S DIR(0)="E",DIR("A")=" to Continue ""^"" to Exit" D ^DIR I Y'=1 G EXIT ;====>> D ^DGPM5 S ^XTMP(MAS1,MASI)=1 S DIR(0)="E",DIR("A")=" to Continue ""^"" to Exit" D ^DIR I Y'=1 G EXIT ;====>> ; ; POST ;EP ;searhc/maw this should be called last, it will convert the pointers ;in the V Hospitalization file, patient movement and provider ;pointers S MAS1="MAS_INSTAL",MASI=8,MAS2="POST^MASSETUP",MAS3="POST" S ^XTMP(MAS1,MASI,MAS2,MAS3)=0 W @IOF,?10,MAS2 W !,"Ready to run MAS Post Init Processing .." S DIR(0)="E",DIR("A")=" to Continue ""^"" to Exit" D ^DIR I Y'=1 G EXIT D ^ADGGFL S DIR(0)="E",DIR("A")=" to Continue ""^"" to Exit" I Y'=1 G EXIT D ^ADGCP S ^XTMP(MAS1,MASI)=1 S DIR(0)="E",DIR("A")=" to Continue ""^"" to Exit" I Y'=1 G EXIT ; DELINI ;EP delete routines S MAS1="MAS_INSTAL",MASI=9,MAS2="Delete Inits",MAS3="DELINI" S ^XTMP(MAS1,MASI,MAS2,MAS3)=0 S DIR(0)="E",DIR("A")=" to Continue ""^"" to Exit" D ^DIR I Y'=1 G EXIT ;====>> W @IOF,?10,MAS2 W !,"Ready to Delete Inits .." S DIR(0)="E",DIR("A")=" to Continue ""^"" to Exit" D ^DIR I Y'=1 G EXIT ;====>> K DIR S DIR(0)="Y" K ^XTMP("ZIBRSEL",$J) S Z=$$RSEL^ZIBRSEL("DGINI-DGINIZZ") D DEL S Z=$$RSEL^ZIBRSEL("DGONI-DGONIZZ") D DEL S Z=$$RSEL^ZIBRSEL("DG5INI-DG5INIZZ") D DEL S Z=$$RSEL^ZIBRSEL("DGYP-DGYPZZZ") D DEL S Z=$$RSEL^ZIBRSEL("SDINI-SDINIZZZ") D DEL S Z=$$RSEL^ZIBRSEL("SDONI-SDONIZZZ") D DEL S Z=$$RSEL^ZIBRSEL("ORINI-ORINIZZZ") D DEL S Z=$$RSEL^ZIBRSEL("DPTIN-DPTINZZZ") D DEL K ^XTMP("ZIBRSEL",$J) S ^XTMP(MAS1,MASI)=1 ; FINISH ;EP W !,"MAS VERSION 5.0 Installation has been completed" W !,"Proceed with step 11 of the installation instructions" S DIR(0)="E",DIR("A")="" D ^DIR ; EXIT ;EP D EN^XBVK("MAS"),EN^XBVK("XB") Q DEL ;EP W !!,Z S X="" F I=1:1 S X=$O(^TMP("ZIBRSEL",$J,X)) Q:X="" D . W ?(10*I),X . X ^%ZOSF("DEL") . I I=7 W ! S I=0 Q SET ;EP S X1=DT,X2=30 D C^%DTC S MAS1="MAS_INSTAL",MASI=1,MAS2="D ^DGYPINIT",MAS3="DGYPINIT" S ^XTMP(MAS1,MASI,MAS2,MAS3)=0 S MAS1="MAS_INSTAL",MASI=2,MAS2="D ^ORINIT",MAS3="ORINIT" S ^XTMP(MAS1,MASI,MAS2,MAS3)=0 S MAS1="MAS_INSTAL",MASI=3,MAS2="D ^DPTINIT",MAS3="DPTINIT" S ^XTMP(MAS1,MASI,MAS2,MAS3)=0 S MAS1="MAS_INSTAL",MASI=4,MAS2="D ^DGINIT",MAS3="DGINIT" S ^XTMP(MAS1,MASI,MAS2,MAS3)=0 S MAS1="MAS_INSTAL",MASI=5,MAS2="D ^DG5INIT",MAS3="DG5INIT" S ^XTMP(MAS1,MASI,MAS2,MAS3)=0 S MAS1="MAS_INSTAL",MASI=6,MAS2="D ^SDINIT",MAS3="SDINIT",MAS3="SDINIT" S ^XTMP(MAS1,MASI,MAS2,MAS3)=0 S MAS1="MAS_INSTAL",MASI=7,MAS2="D ^DGPM5 part 1",MAS3="DGPM5P1" S ^XTMP(MAS1,MASI,MAS2,MAS3)=0 S MAS1="MAS_INSTAL",MASI=8,MAS2="D ^DGPM5 part 2",MAS3="DGPM5P2" S ^XTMP(MAS1,MASI,MAS2,MAS3)=0 S MAS1="MAS_INSTAL",MASI=9,MAS2="D POST^MASSETUP",MAS3="POST" S ^XTMP(MAS1,MASI,MAS2,MAS3)=0 S MAS1="MAS_INSTAL",MASI=10,MAS2="Delete Inits",MAS3="DELINI" S ^XTMP(MAS1,MASI,MAS2,MAS3)=0 Q SDAL SDAL ; IHS/ADC/PDW/ENM - APPOINTMENT LIST 16 NOV 84 ; [ 05/21/1999 10:32 AM ] ;;5.0;IHS SCHEDULING;**2**;MAR 25, 1999 ;;MAS VERSION 5.0; ;IHS/ANMC/RAM,LJF ; -- added choice to include/exclude walk-ins ; -- added choice to include who made appt ; -- removed assumption for future dates ;IHS/HQW/KML 2/12/97 replace $N with $O w/o changing functionality ; D ASK2^SDDIV G:Y<0 END S VAUTNI=1 D CLINIC^VAUTOMA G:Y<0 END RD1 ;K DIC("S") S %DT("A")="FOR DATE: ",%DT="AEXF" D ^%DT K %DT;IHS orig va K DIC("S") S %DT("A")="FOR DATE: ",%DT="AEX" D ^%DT K %DT ;IHS chgd I (X["^")!(Y<0) K %,VAUTD,VAUTC,X,Y Q S SDD=Y N K SDX,SDX1 R !,"NUMBER OF COPIES: 1// ",M:DTIME S:M="" M=1 I M["^" K M,SDD,VAUTC,VAUTD,X,Y Q I (M'?.N)!((M'>0)!($L(M)>3)) W !,"ENTER A WHOLE NUMBER TO SELECT THE # OF COPIES OF THE APPOINTMENT LIST THAT ARE NEEDED- (1-999)" G N D ASK^ASDAL G END:$D(ASDQ) ;IHS added call ;S DGVAR="VAUTD#^VAUTC#^M^SDD",DGPGM="START^SDAL" ;IHS orig va S DGVAR="VAUTD#^VAUTC#^M^SDD^ASDWI^ASDAMB^ASDPH",DGPGM="START^SDAL" ;IHS/DSD/ENM 05/21/99 ASDPH ADDED D ZIS^DGUTQ G:POP END START U IO S:'$D(DTIME) DTIME=300 I '$D(DT) D DT^SDUTL S (SDEND,SD1,PCNT,SDB)=0,Y=DT D D^DIQ S SDNT=Y,Y=SDD,X=Y D D^DIQ S SDPD=Y,SDTT=$S($E(IOST)="C"&(IOSL<66):1,1:0) D DW^%DTC S SDPD=$E(X,1,3)_" "_SDPD LOOPA S SD=0 F SDXX=0:0 S SD=$S(VAUTC:$O(^SC("B",SD)),1:$O(VAUTC(SD))) Q:SD="" D CLIN G:SDEND END ;changed from Q:'SD maw OVER S PCNT=PCNT+1,SDB=0 G:PCNT0!(SDIN>SD):0,SDRE'>SD&(SDRE):0,1:1) W !,*7,"Clinic is inactive ",$S('SDRE:"as of ",1:"from ") S Y=SDIN D DTS^SDUTL W Y,SDRE1 G SDC I '$D(^SC(SC,"ST",SD,1)) S DH="" D B S ^SC(SC,"ST",SD,1)=$P("SU^MO^TU^WE^TH^FR^SA",U,DOW+1)_" "_$E(SD,6,7)_$J("",SI+SI-6)_DH,^(0)=SD G N I ^(1)["CANCELLED" W !,"APPOINTMENTS HAVE ALREADY BEEN CANCELLED",!,*7 S ANS="N",SDTIME="*",SDV1=$S($P(^SC(SC,0),"^",15):$P(^(0),"^",15),1:$O(^DG(40.8,0))) K SDX G ASKL^SDC0 N I '$F(^SC(SC,"ST",SD,1),"[") K ^SC(SC,"ST",SD) W !,*7,"CLINIC DOES NOT MEET ON THAT DAY" G SDC I $O(^SC(SC,"S",SD))\1-SD W *7,!?5,"NO APPOINTMENTS SCHEDULED" S NOAP=1 G W W !,"FIRST, I'LL LIST THE EXISTING APPOINTMENTS",! K DUOUT,DTOUT D ^SDC1 I $D(DUOUT)!$D(DTOUT) D END^SDC0 Q I ^SC(SC,"ST",SD,1)["X" G ^SDC2 W S DH=0,%="" W !,"WANT TO CANCEL THE WHOLE DAY" D YN^DICN I '% W !,"REPLY YES (Y) OR NO (N)" G W G ALL:%=1 Q:%<1 WP S %="" W !,"WANT TO CANCEL PART OF THE DAY" D YN^DICN I '% W !,"REPLY YES (Y) OR NO (N)" G WP Q:(%-1) F R !,"STARTING TIME: ",X:DTIME Q:U[X D TC^SDC2 G F:Y<0 S FR=Y,ST=% T R !,"ENDING TIME: ",X:DTIME Q:U[X D TC^SDC2 G T:Y<0 S SDHTO=X,TO=Y I TO'>FR W !,"Ending time must be greater than starting time",*7 G T ROPT R !,"(OPTIONAL) MESSAGE: ",I:DTIME I I?1"?".E W !,"YOU MAY ENTER A MESSAGE CONCERNING THE CANCELLATION HERE" G ROPT Q:I["^" I '$D(^SC(SC,"SDCAN",0)) S ^SC(SC,"SDCAN",0)="^44.05D^"_FR_"^1" G SKIP S A=^SC(SC,"SDCAN",0),SDCNT=$P(A,"^",4),^SC(SC,"SDCAN",0)=$P(A,"^",1,2)_"^"_FR_"^"_(SDCNT+1) SKIP S ^SC(SC,"SDCAN",FR,0)=FR_"^"_SDHTO S NOAP=$S($O(^SC(SC,"S",(FR-.0001)))'>0:1,$O(^SC(SC,"S",(FR-.0001)))>TO:1,1:0) I 'NOAP S NOAP=$S($O(^SC(SC,"S",$O(^SC(SC,"S",(FR-.0001))),0))="MES":1,1:0) S ^SC(SC,"S",FR,0)=FR,^("MES")="CANCELLED UNTIL "_X_$S(I?.P:"",1:" ("_I_")") D S S I=^(1),I=I_$J("",%-$L(I)),Y="" F X=0:2:% S DH=$E(I,X+SI+SI),P=$S(XIOSL) S DIR(0)="E" D:$E(IOST,1,2)="C-" ^DIR K DIR Q:$D(DTOUT)!$D(DUOUT) D HED ;W !,$P(^DPT(DFN,0),"^",1),?32,$P(^(0),"^",9) S X=J D TM^SDROUT0 W ?43,$J(X,8),?58,SDLE W:$D(^DPT(DFN,.13)) ?64,$P(^(.13),"^",1) ;IHS orig va W !,$P(^DPT(DFN,0),"^",1),?32,$$HRN^ADGF(DFN) S X=J D TM^SDROUT0 W ?43,$J(X,8),?58,SDLE W:$D(^DPT(DFN,.13)) ?64,$P(^(.13),"^",1) ;IHS chgd S SDCNT=SDCNT+1 Q HED ;W @IOF,!,$P(^SC(SC,0),"^",1)," Clinic Pre-cancellation list",!,"PATIENT NAME",?34,"SSN",?43,"APPT TIME",?56,"LENGTH",?64,"TELEPHONE" ;IHS orig va W @IOF,!,$P(^SC(SC,0),"^",1)," Clinic Pre-cancellation list for ",$$DT(CDATE),!,"PATIENT NAME",?34,"HRN",?43,"APPT TIME",?56,"LENGTH",?64,"TELEPHONE" ;IHS chgd W ! F I=1:1:79 W "-" Q ; DT(Y) ; X ^DD("DD") Q Y SDCLDOW SDCLDOW ; IHS/ADC/PDW/ENM - PRINT LIST OF CLINICS BY DAY OF WEEK 29 FEB 84 2:22 pm ; [ 08/03/1999 3:53 PM ] ;;5.0;IHS SCHEDULING;**3**;MAR 25, 1999 ;;MAS VERSION 5.0; ;IHS/ANMC/RAM,LJF ; -- added choice of clinics to print ;IHS/HQW/KML 2/13/97 replace $N with $O w/o changing functionality ; S:'$D(DTIME) DTIME=300 I '$D(DT) D DT^SDUTL S DIV="" I $D(^DIC(4,+^DD("SITE",1),"DIV")),^("DIV")="Y" S DIC("A")="CLINIC LIST BY DOW FOR WHICH DIVISION: " D ASK^SDDIV Q:Y<0 D ASK^ASDCLDOW I $D(ASDQ) K ASDQ G END ;IHS added call ;S VAR="DIV",VAL=DIV,PGM="START^SDCLDOW" D ZIS^DGUTQ Q:POP;IHS orig va S VAR="VAUTC#^DIV",VAL=DIV,PGM="START^SDCLDOW" D ZIS^DGUTQ Q:POP ;IHS chgd START U IO S (END,SDPG)=0 S LINE1="|------------------------------------|-----|-----|-----|-----|-----|-----|-----|",SDIV=$S(DIV:DIV,1:1) ;IHS/DSD/ENM 08/03/99 NEXT LINE COPIED/MODIFIED ;D TOF S SCN=0 F KK=0:0 S SCN=$O(^SC("B",SCN)) G:'SCN!(END) END S SC=$O(^SC("B",SCN,0)) D CHECK I $T D SET,PRT D TOF S SCN=0 F KK=0:0 S SCN=$O(^SC("B",SCN)) G:SCN=""!(END) END S SC=$O(^SC("B",SCN,0)) D CHECK I $T D SET,PRT G END END I IOST["C-",'$G(END) D PRTOPT^ASDVAR ;IHS added code K VAUTC,VAUTD ;IHS added K I,SDCL,LINE1,PGM,NAME,POP,SDALL,SCN,END,M,L,DOW,SDOS,SC,SDPG,X,Y D CLOSE^DGUTQ Q SET S NAME=$P(^SC(SC,0),"^",1) K DOW F L=DT-.1:0 S L=$O(^SC(SC,"T",L)) Q:'L S X=L D DW^%DTC S:'$D(^SC(SC,"T"_Y,L,1)) DOW(Y+1)="F" F L=0:1:6 I '$D(DOW(L+1)) F M=DT-.1:0 S M=$O(^SC(SC,"T"_L,M)) Q:'M I $D(^(M,1)),^(1)]"" S DOW(L+1)=$S($O(^SC(SC,"T"_L,DT))=M:"C",1:"F") Q F M=DT-.1:0 S M=$O(^SC(SC,"OST",M)) Q:'M S X=M D DW^%DTC I '$D(DOW(Y+1)),$D(^SC(SC,"OST",M,1)),^(1)["[" S DOW(Y+1)="C" Q PRT I $Y+7>IOSL D:IOSL<25 SEEND:IOST?1"C-".E Q:END D TOF I $D(DOW) W !,"|",NAME W ?37,"|" F M=1:1:7 S SDOS=(M+6)*6-3 W:$D(DOW(M)) ?SDOS,"*",DOW(M),"*" S SDOS=SDOS+4 W ?SDOS,"|" K SDOS I $D(DOW) W ! W LINE1 Q SEEND R !,"Press return to continue or ""^"" to escape ",CXEND:DTIME I '$T!(CXEND="^") S END=1 Q Q TOF ;W @IOF,!!,?2,"FACILITY: ",$P(^DG(40.8,+SDIV,0),"^",1),!,?2,"CLINIC LIST BY DAY OF WEEK AS OF " S Y=DT D DT^DIQ S SDPG=SDPG+1 W ?(IOM-10),"PAGE: ",SDPG;IHS orig va I SDPG>0!(IOST["C-") W @IOF ;IHS chgd W !!,?2,"FACILITY: ",$P(^DG(40.8,+SDIV,0),"^",1),!,?2,"CLINIC LIST BY DAY OF WEEK AS OF " S Y=DT D DT^DIQ S SDPG=SDPG+1 W ?(IOM-10),"PAGE: ",SDPG ;IHS unchanged part of orig va line W !!,?3,"*C* = CLINIC CURRENTLY MEETS ON THIS DAY",!,?3,"*F* = CLINIC WILL MEET IN THE FUTURE ON THIS DAY",!! W !,"CLINIC:",?37,"| SUN | MON | TUE | WED | THU | FRI | SAT |" S I="",$P(I,"=",81)="" W !,I Q CHECK ;I $P(^SC(SC,0),"^",3)="C",$S(DIV="":1,$P(^SC(SC,0),"^",15)=DIV:1,1:0) ;IHS orig va I $P(^SC(SC,0),"^",3)="C",$S(DIV="":1,$P(^SC(SC,0),"^",15)=DIV:1,1:0),$S(VAUTC=1:1,$D(VAUTC($P(^SC(SC,0),U))):1,1:0),$$ACTV^ASDUT(SC) ;IHS chgd Q SDCLK SDCLK ; IHS/ADC/PDW/ENM - LOOK UP CLERK WHO MADE APPOINTMENT 22 FEB 88 ; [ 12/15/1999 9:14 AM ] ;;5.0;IHS SCHEDULING;**3**;MAR 25, 1999 ;;MAS VERSION 5.0; ;IHS/ANMC/RAM,LJF ; -- added entry point for call from IHS rtn ; -- changed SSN to HRCN ; -- added appt length & other info to display ;IHS/HQW/KML 2/13/97 replace $N with $O w/o changing functionality ; EN D Q W !! S DIC="^DPT(",DIC(0)="AEQMZ" D ^DIC G Q:Y'>0 S DFN=+Y I '$D(^DPT(DFN,"S")) W !,"No appointments scheduled for this patient." G EN C K ^UTILITY($J) S DIC("A")="Enter CLINIC: ",DIC="^SC(",DIC(0)="AEQMZ",DIC("S")="I $P(^(0),U,3)=""C""" D ^DIC G:Y'>0!(X="") EN S SDIFN=+Y F I=0:0 S I=$O(^DPT(DFN,"S",I)) Q:'I I $D(^(I,0)),($P(^(0),U)=SDIFN) S ^UTILITY($J,"A",10000000-I)="" K DIC I '$D(^UTILITY($J,"A")) W "There are no appointments for this patient to this clinic." G C A R !,"Enter APPOINTMENT DATE/TIME: ",X:DTIME G C:X="^"!(X="")!('$T) S %DT="ETPX",%DT(0)=2820100 G L:X["??",H:X["?" D ^%DT G A:Y'>0 I '$D(^UTILITY($J,"A",10000000-Y)) G ON:X'["."&(Y>2820100) D H G A S SDA=Y P ;EP; called by ^ASDAMB ;IHS added comment ;Q:'$D(^DPT(DFN,0)) S SDS=$P(^(0),U,9) W !,"Patient Name",?32,": ",$P(^(0),U),?60,"SSN: ",$E(SDS,1,3),"-",$E(SDS,4,5),"-",$E(SDS,6,10),!,"Clinic Name",?32,": ",$S($D(^SC(SDIFN,0)):$P(^(0),U),1:""),!,"Appointment Date/Time",?32,": " ;IHS Q:'$D(^DPT(DFN,0)) S SDS=$P(^(0),U,9) W !,"Patient Name",?32,": ",$P(^(0),U),?60,"HRCN: ",$$HRCN^ADGF,!,"Clinic Name",?32,": ",$S($D(^SC(SDIFN,0)):$P(^(0),U),1:""),!,"Appointment Date/Time",?32,": " ;IHS chgd ;K SDS S Y=SDA D DT^DIQ F I=0:0 S I=$O(^SC(SDIFN,"S",SDA,1,I)) Q:'I!'$D(^(I,0)) I $P(^(0),U)=DFN S SDS=^(0),SDC=$P(SDS,U,6) Q K SDS S Y=SDA D DT^DIQ F I=0:0 S I=$O(^SC(SDIFN,"S",SDA,1,I)) Q:'I Q:'$D(^(I,0)) I $P(^(0),U)=DFN S SDS=^(0),SDC=$P(SDS,U,6) Q ;IHS/DSD/LWJ 08/26/99 I '$D(SDS) S (SDS,SDC)="" K SDC1,SDC2 S:$P(^DPT(DFN,"S",SDA,0),"^",18) SDC1=$P(^DPT(DFN,"S",SDA,0),"^",18) S:$P(^DPT(DFN,"S",SDA,0),"^",19) SDC2=$P(^DPT(DFN,"S",SDA,0),"^",19) W !!,"Appointment Made By",?32,": " S:$D(SDC1) SDC=SDC1 W:SDC $S($D(^VA(200,SDC,0)):$P(^(0),U),1:"") W !,"Date Appointment Made",?32,": " S Y=$P(SDS,U,7) S:$D(SDC2) Y=SDC2 D DT^DIQ W !,"Purpose of Visit",?32,": " S SDP=$S($D(^DPT(DFN,"S",SDA,0)):^(0),1:""),SDS=$P(SDP,U,2),SDPP=$P(SDP,U,7),SDP3=$P(SDP,U,14) W $S(SDPP=1:"C&P",SDPP=2:"10-10",SDPP=3:"SCHEDULED VISIT",SDPP=4:"UNSCHED. VISIT",1:"") K DIC,X,Y S SDAP=0 S:$P(SDP,U,16) SDAP=$P(SDP,U,16) W !,"Appointment Type",?32,": " I SDAP S SDAP1=$P(^SD(409.1,SDAP,0),"^") W SDAP1 S (APL,OTH)="",ASDX=0 F S ASDX=$O(^SC(SDIFN,"S",SDA,1,ASDX)) Q:'ASDX I +^(ASDX,0)=DFN S APL=$P(^SC(SDIFN,"S",SDA,1,ASDX,0),U,2),OTH=$P(^(0),U,4) ;IHS added W !,"Appt. Length",?32,": ",APL,!,"Other Info",?32,": ",OTH K APL,OTH ;IHS added I $P(SDP,U,17) W !,"Appt. Cancelled to make ",!,"this appt.",?32,": ",$P(^SC($P(SDP,U,17),0),U) STATUS W !!,"Appointment Status",?32,": " S SDSTAT=^DD(2.98,3,0) F SD9=1:1:8 I SDS=$P($P($P(SDSTAT,"^",3),";",SD9),":") W $P($P($P(SDSTAT,"^",3),";",SD9),":",2) I SDP3 S SDP1=$S($P(SDP,U,12):$P(^VA(200,$P(SDP,U,12),0),U,1),1:"") W !,"No-show/Cancelled By",?32,": ",SDP1 S Y=SDP3 W !,"No-show/Cancel Date/Time" W ?32,": " D DT^DIQ S SDP2=$P(SDP,U,15) I SDP2 W !,"Cancellation Reason",?32,": ",$P(^SD(409.2,SDP2,0),U) I $D(^DPT(DFN,"S",SDA,"R")) W !,"Cancellation Remarks",?32,": " F X5=0:46:$L(^("R")) W ?34,$E(^("R"),X5,X5+45),! S SDP4=$P(SDP,U,10) I SDP4 S Y=SDP4 W !,"Rescheduled for",?32,": " D DT^DIQ W ! K DIC,X,X5,Y,I,SD9,SDA,SDAP,SDAP1,SDD,SDP1,SDP2,SDP3,SDP4,SDQ I $D(SD) F I=1:1:SD K ^UTILITY($J,"A",I) ;G A ;IHS orig va Q ;IHS chgd Q K ^UTILITY($J,"A"),%DT,DIC,DIPGM,DFN,I,SDIFN,J,N,SD,SDA,SDB,SDC,SDD,SDE,SDF,SDFT,SDP,SDPP,SDQ,SDS,SDSTAT,SDC1,SDC2,C,%,%Y,X,Y Q ON S Y=10000000-Y,SDB=Y+.1,SDE=Y-.9,(J,N)=0 F I=SDE:0 S I=$O(^UTILITY($J,"A",I)) Q:'I!(I>SDB) S J=J+1,SDD(J,10000000-I)="" I J=1 S SDA=0,SDA=$O(SDD(J,SDA)) G P I '$D(SDD) W !,"No appointments on date selected." G A W @IOF,"Choose from: " F I=1:1:J W !,?5,I,")",?9 S X=0,X=$O(SDD(I,X)) D ^%DT QA W !,"Enter a number 1-",J,": " R X:DTIME G A:X="^"!(X="")!('$T),QA:X["?"!(X<1)!(X>J) S N=$O(SDD(X,N)) S SDA=N G P H W !!,"Enter:",!,"(1) '??' to see a list of appointments.",!,"(2) Date alone to see appointments for this patient to this clinic on a date.",!,"(3) A valid appointment date after JAN 1, 1982.",!! G A L S (SD,SDF,SDFT)=0 F I=0:0 S I=$O(^UTILITY($J,"A",I)) Q:'I S SD=SD+1,^UTILITY($J,"A",SD,10000000-I)="" F I=1:1:SD S Y=0,Y=$O(^UTILITY($J,"A",I,Y)) W !,?5,I,")",?12 D DT^DIQ D:'(I#5) P5 G P:SDF,Q:$D(SDQ) S SDFT=1 P5 W !,"Enter a number 1-",I," or '^' to exit: " R X:DTIME S:(X="^")!('$T) SDQ="" Q:X=""!$D(SDQ)&('SDFT) G Q:$D(SDQ),P5:(I=SD)&(X="")!$S($L(X)>5:1,X<1:1,X>I:1,X'=+X:1,1:0) S SDA=0,SDA=$O(^UTILITY($J,"A",X,SDA)) G:SDFT P S SDF=1 Q SDCP SDCP ; IHS/ADC/PDW/ENM - CLINIC LIST 12/3/90 16:28 ; [ 05/27/1999 3:37 PM ] ;;5.0;IHS SCHEDULING;**2**;MAR 25, 1999 ;;MAS VERSION 5.0; ;IHS/ANMC/RAM,LJF ; -- added end of page control ;IHS/HQW/KML 2/13/97 replace $N with $O w/o changing functionality ; D ASK2^SDDIV G:Y<0 END S VAUTNI=1 D CLINIC^VAUTOMA G:Y<0 END S DGPGM="START^SDCP",DGVAR="VAUTD#^VAUTC#" D ZIS^DGUTQ G:POP END U IO START U IO S END=0 D:'$D(DT) DT^SDUTL S Y=DT D DTS^SDUTL S PDATE=Y,SCN=0 D TOF G:'VAUTC SOME ;F KK=0:0 S SCN=$O(^SC("B",SCN)) Q:'SCN!(END) S SC=$O(^SC("B",SCN,0)) D CHECK I $T D SET0,SETSL,PRT ;IHS orig va ;F KK=0:0 S SCN=$O(^SC("B",SCN)) Q:'SCN!(END) S SC=$O(^SC("B",SCN,0)) D CHECK I $T D SET0,SETSL,PRT^ASDCP Q:ASDSTOP=U ;IHS chgd F S SCN=$O(^SC("B",SCN)) Q:SCN="" S SC=$O(^SC("B",SCN,0)) D CHECK I $T D SET0,SETSL,PRT^ASDCP Q:ASDSTOP=U ;IHS/DSD/ENM 05/27/99 G END SOME ;F KK=0:0 S SCN=$O(VAUTC(SCN)) Q:'SCN!(END) S SC=+VAUTC(SCN) D CHECK I $T D SET0,SETSL,PRT ;IHS orig va ;F KK=0:0 S SCN=$O(VAUTC(SCN)) Q:'SCN!(END) S SC=+VAUTC(SCN) D CHECK I $T D SET0,SETSL,PRT^ASDCP Q:ASDSTOP=U ;IHS chgd F KK=0:0 S SCN=$O(VAUTC(SCN)) Q:SCN="" S SC=+VAUTC(SCN) D CHECK I $T D SET0,SETSL,PRT^ASDCP Q:ASDSTOP=U ;IHS/DSD/ENM 05/27/99 G END END I IOST["C-",$G(ASDSTOP)'=U D PRTOPT^ASDVAR ;IHS added code K ASDSTOP ;IHS added line W ! K ABBR,ALV,C,CXEND,DAYS,DIC,DIPH,DOW,END,HCDB,I,J,KK,L,LOC,LOP,M,NAME,ODM,PC,PDATE,POP,SCSC,SDMX,SDNO,SDNO,SDC,SDCR,SCSC,SCN,SDIN,SDPR,SDRE,STCD,STDAT,X,Y,SD,SDCNT,VAUTC,VAUTD D CLOSE^DGUTQ Q SET0 S NAME=$P(^SC(SC,0),U,1),ABBR=$P(^(0),U,2),LOC=$P(^(0),U,11),(STCD,SDSC)=$P(^(0),U,7),SDCR=$P(^(0),U,18),SDCNT=$P(^(0),U,17) S:$D(^SC(SC,"SDP")) SDMX=$P(^SC(SC,"SDP"),U,2) Q SETSL S (LOP,HCDB,ALV,PC,ODM,DIPH,STDAT)="",STCD=$S(STCD="":" ",1:STCD),STCD=$S('$D(^DIC(40.7,+STCD,0)):"",1:$P(^(0),U,2)),SDSC=$S($D(^DIC(40.7,+SDSC,0)):'$P(^(0),U,3)!($P(^(0),U,3)>DT),1:0) S SDPR=$S('$D(^SC(SC,"SDPROT")):"NO",'$L($P(^("SDPROT"),U)):"NO",1:"YES") S SDCR=$S(SDCR="":" ",1:SDCR),SDCR=$S('$D(^DIC(40.7,+SDCR,0)):"",1:$P(^(0),U,2)) I $D(^SC(SC,"SL")) S LOP=$P(^SC(SC,"SL"),U,1),HCDB=$P(^("SL"),U,3),ALV=$S($P(^("SL"),U,2)["V":"YES",1:"NO") I S PC=$S($P(^("SL"),U,5)]"":$P(^SC($P(^("SL"),U,5),0),U,1),1:""),ODM=$P(^SC(SC,"SL"),U,7),DIPH=$S($P(^("SL"),U,6)=4:15,$P(^("SL"),U,6)=3:20,$P(^("SL"),U,6)=1:60,$P(^("SL"),U,6)=2:30,1:10) ;S STDAT=$S($D(^SC(SC,"T")):$O(^SC(SC,"T",0)),1:"UNKNOWN") ;IHS orig S STDAT=$S($O(^SC(SC,"T")):$O(^SC(SC,"T",0)),1:"UNKNOWN") ;IHS chgd K DOW F L=0:1:6 F M=DT-.1:0 S M=$O(^SC(SC,"T"_L,M)) Q:'M I $D(^(M,1)) S:^(1)]"" DOW(L+1)="" Q:^(1)]"" K DOW(L+1) F L=DT-.1:0 S L=$O(^SC(SC,"T",L)) Q:'L S X=L D DW^%DTC I '$D(DOW(Y+1)),$D(^SC(SC,"OST",L,1)),^(1)["[" S DOW(Y+1)="" S DAYS="" F M=1:1:7 I $D(DOW(M)) S DAYS=DAYS_$S(DAYS'="":",",1:"")_$P("SU^MO^TU^WE^TH^FR^SA",U,M) Q PRT I $Y+12>IOSL D:IOSL<25 SEEND:$E(IOST,1,2)="C-" Q:END D TOF S SDNO="" W !,"CLINIC: ",NAME,?33,"ABBR: ",ABBR,?47,"TELEPHONE: ",$S($D(^SC(SC,99)):^SC(SC,99),1:"") I $D(^SC(SC,"I")) S SDRE=+$P(^("I"),U,2),SDIN=+^("I") I SDRE'=SDIN D:SDIN'>DT&(SDRE=0!(SDRE>DT)) INACT W !,"LOCATION: ",LOC W:'SDNO ?38,"DAYS CLINIC MEETS: ",DAYS I 'SDNO S Y=STDAT D:STDAT'="UNKNOWN" DTS^SDUTL W !,"START DATE: ",$S(STDAT="UNKNOWN":"UNKNOWN",1:Y) W:SDNO ! W:'SDNO ?23 W "INCREMENTS: ",DIPH_"-MINUTES",?48,"HOUR DISPLAY BEGINS: ",$S(HCDB="":"8 AM",HCDB<13:HCDB_" AM",1:HCDB-12_" PM") W !,"APPOINTMENT LENGTH: ",LOP,?28,"VARIABLE: ",ALV,?43,"MAX OVERBOOKS/DAY: ",ODM,!,"STOP CODE: ",STCD,?20,"CREDIT STOP CODE: ",SDCR,?46,"NON-COUNT CLINIC: ",$S(SDCNT="Y":"YES",1:"NO") W !,"PROHIBIT ACCESS TO CLINIC: ",SDPR W:$D(SDMX) !,"MAX # DAYS FOR FUTURE BOOKING: ",SDMX W:PC]"" !,"PRINCIPAL CLINIC: ",PC I 'SDNO,$D(SDIN),SDIN>DT,SDRE'=SDIN W !,?4,"**** Clinic will be inactive ",$S(SDRE:"from ",1:"as of ") S Y=SDIN D DTS^SDUTL W Y S Y=SDRE D:Y DTS^SDUTL W $S(SDRE:" to "_Y,1:"")," ****" K SDIN,SDRE I 'SDSC W !,?4,"*** INVALID OR INACTIVE STOP CODE ASSIGNED TO THIS CLINIC ***" W !! ;F Z=1:1:IOM W "*" Q INACT ;EP; IHS added comments-called by ASDCP S Y=SDIN D DTS^SDUTL W !!,?4,"**** Clinic is inactive ",$S(SDRE:"from ",1:"as of "),Y S Y=SDRE D:Y DTS^SDUTL W $S(SDRE:" to "_Y,1:"")," ****",! K SDIN,SDRE S SDNO=1 Q SEEND R !,"ENTER '^' TO STOP ",CXEND:DTIME I CXEND=U!('$T) S END=1 Q TOF W @IOF,?22,"CLINIC PROFILES AS OF: ",PDATE,! Q CHECK I $D(^SC(SC,0)),($P(^(0),U,3)="C"),$S(VAUTD:1,$D(VAUTD(+$P(^(0),U,15))):1,'$P(^(0),U,15)&($D(VAUTD($O(^DG(40.8,0))))):1,1:0) Q SDCWL SDCWL ; IHS/ADC/PDW/ENM - CLINIC WORKLOAD REPORT 18 APRIL 88 ; [ 11/24/1999 2:41 PM ] ;;5.0;IHS SCHEDULING;**3**;MAR 25, 1999 ;;MAS VERSION 5.0; ;IHS/HQW/KML 2/13/97 replace $N with $O w/o changing functionality D Q S U="^" D ASK2^SDDIV G Q:Y<0 S (VAUTC,SDADD,SDALL,SDNAM,SDPRE)=0 D DATE^SDUTL G Q:POP,DT:($E(SDBD,6,7)&$E(SDED,6,7)) S:'$E(SDBD,4,5) SDBD=$E(SDBD,1,3)_"0101" S:'$E(SDED,4,5) SDED=$E(SDED,1,3)_"1231" S:'$E(SDBD,6,7) SDBD=$E(SDBD,1,5)_"01" S:'$E(SDED,6,7) SDED=$E(SDED,1,5)_"31" DT S SDB=$E(SDBD,4,5)_"/"_$E(SDBD,6,7)_"/"_$E(SDBD,2,3),SDE=$E(SDED,4,5)_"/"_$E(SDED,6,7)_"/"_$E(SDED,2,3),SDBD=SDBD-.1,SDED=SDED+.9 I SDED<2871001 S SDS="C" S VAUTNI=2 D CLINIC^VAUTOMA G Q:Y<0,RT 1 R !,"Totals by (C)LINIC or (S)TOP CODE?: C//",X:DTIME G Q:(X="^")!'$T S Z="^CLINIC^STOP CODE" W:X["?" !,"Type:",!?10,"'C' for CLINIC totals only, or",!?10,"'S' for STOP CODE and CLINIC totals",! I X="" S X="C" W X D IN^DGHELP G:%=-1 1 S SDS=X I SDS="C" S VAUTNI=2 D CLINIC^VAUTOMA G Q:Y<0,RT 2 F SDI=1:0 Q:SDI>20 W !,"Enter Stop Code: " W:'$D(SDCL) "ALL//" R X:DTIME Q:(X="^")!'$T!(X="") W:X["?" !,"Enter a stop code or return when all stop codes have been entered" D CL^SDSCP G:X="^"!('$T&(SDI<20)) Q I X="",'$D(SDCL) S SDCL="",SDALL=1 ADD I SDS="S" W !,"Do you want to include add/edits" S %=2 D YN^DICN W:%Y["?" !,"Answer 'Y'es to see add/edits entered through the ADD/EDIT STOP CODES option or",!,"'N'o to leave them out" G Q:%<0,ADD:%'>0 S SDADD='(%-1) RT I SDS="S"&((SDBD-10000)<2871000) S SDRT="E" G 3 R !,"Brief or Expanded Report? E//",X:DTIME G Q:X="^"!'$T S Z="^BRIEF^EXPANDED" W:X["?" !,"Enter 'B'rief to see a comparison of data to previous year only",!,"or 'E'xpanded to see patient breakdown by clinic/stop code" I X="" S X="E" W X D IN^DGHELP S SDRT=X G RT:%=-1,ST:X="B" 3 W !,"(D)ETAIL BY DAY or (S)UMMARY BY MONTH?: D//" R X:DTIME G Q:(X="^")!'$T W:X["?" !,"TYPE:",!?10,"'D' for report by individual clinic meeting",!?10,"'S' for report by month" I X="" S X="D" W X S Z="^DETAIL BY DAY^SUMMARY BY MONTH" D IN^DGHELP G:%=-1 3 S SDF=X PN I SDF="D" W !,"Do you want to see patient names" S %=2 D YN^DICN W:%Y["?" "ANSWER 'Y'ES OR 'N'O" G Q:%<0,PN:%'>0 S SDNAM='(%-1) 5 I SDS="C"!((SDBD-10000)>2871000) W !,"Do you want to compare this data to the same period in the previous year" S %=2 D YN^DICN W:%Y["?" "ANSWER 'Y'ES OR 'N'O" G Q:%<0,5:%'>0 S SDPRE='(%-1) W !!,"Report will cover the period from: ",SDB," through ",SDE W:SDPRE !,"Comparison will be done against the same period for the previous year" W !! ST S DGPGM="6^SDCWL",DGVAR="VAUTC#^VAUTD#^SDALL^SDCL#^SDB^SDBD^SDE^SDED^SDF^SDRT^SDS^SDADD^SDNAM^SDPRE" K IOP D ZIS^DGUTQ G:POP Q U IO D 6,CLOSE^DGUTQ Q 6 ;IHS/DSD/ENM 11/23/99 NEXT LINE ADDED S (SDSCH,SDUN,SDIN,SDOB,SDNS,SDCA)=0 S (SDOB,SDPG,SDHR,SD1)=0,SDCON=$P(^DG(43,1,"SCLR"),U,9),%DT="R",X="N" D ^%DT S SDNOW=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_"@"_$P(Y,".",2) F I=0:0 S I=$S(SDS="S"!VAUTC:$O(^SC(I)),1:$O(VAUTC(I))) Q:I'>0 D SET^SDCWL3 ;IHS/DSD/ENM 11/23/99 NEXT L COPIED/MOD ;I SDADD F I=SDBD:0 S I=$O(^SDV(I)) Q:'I!(I>SDED)!'$D(^(I,0)) F J=0:0 S J=$O(^SDV(I,"CS",J)) Q:'J I $D(^SDV(I,"CS",J,0)) S SDSC=$P(^(0),U) S SDSC=$S('SDSC:0,$D(^DIC(40.7,SDSC,0)):$P(^(0),U,2),1:0) I SDSC D ADDON^SDCWL2 I SDADD F I=SDBD:0 S I=$O(^SDV(I)) Q:'I!(I>SDED) F J=0:0 S J=$O(^SDV(I,"CS",J)) Q:'J I $D(^SDV(I,"CS",J,0)) S SDSC=$P(^(0),U) S SDSC=$S('SDSC:0,$D(^DIC(40.7,SDSC,0)):$P(^(0),U,2),1:0) I SDSC D ADDON^SDCWL2 I (SDRT="B"!SDPRE)&'$D(SDFL) S SDBD=SDBD-10000,SDED=SDED-10000,SDFL=1 G 6 I '$D(^UTILITY($J,"CL")),'$D(^("SC")) D NONE^SDCWL3 G Q G Q:'$D(^UTILITY($J)) D:SDRT="E"&($D(^UTILITY($J,1))!$D(^("SC"))) ^SDCWL1,LEG^SDCWL3 D ERR^SDCWL3:$D(^UTILITY($J,"ERR")),PREV^SDCWL2:SDPRE!(SDRT="B") Q W ! K ^UTILITY($J),%,%DT,%Y,BEGDATE,DFN,DGPGM,DGVAR,DIV,ENDDATE,I,I1,J,J1,K,K1,L,L1,M,M1,N,N1,P,POP,Q,Q1,R,S,SD1,SDADD,SDAED,SDALL,SDAPT,SDAS,SDB,SDBD,SDBO,SDCA,SDCL,SDCON,SDCR,SDCUR,SDD,SDDIV,SDE,SDED,SDEO,SDF,SDF1,SDFL,SDHK,SDHR K SDF2,SDI,SDIN,SDN,SDNAM,SDNM,SDNOW,SDNS,SDNUM,SDOB,SDOLD,SDP,SDPG,SDPN,SDPRE,SDRT,SDS,SDSC,SDSCC,SDSCH,SDSCI,SDSCN,SDSCO,SDSCS,SDSCU,SDSSN,SDST,SDSTAT,SDSUB,SDT,SDTOT,SDUN,SDV,VAUTC,VAUTD,VAUTNI,X,Y,Z Q SDCWL1 SDCWL1 ; IHS/ADC/PDW/ENM - CLINIC WORKLOAD REPORT PRINTOUT 27 APRIL 88 ; [ 11/24/1999 2:40 PM ] ;;5.0;IHS SCHEDULING;**3**;MAR 25, 1999 ;;MAS VERSION 5.0; ;IHS/ANMC/RAM,LJF ; -- changed SSN to chart # ; -- changed for loop to handle stop codes with leading zeros ;IHS/HQW/KML 2/13/97 replace $N with $O w/o changing functionality ; G:SDS="C" CLIN ;F I=2:0 D SCT S I=$O(^UTILITY($J,"SC",I)) Q:'I D ISC S J=0 F J1=0:0 D T:J'="{",AT:J="{" S J=$O(^UTILITY($J,"SC",I,J)) Q:'J D:J="{" ADD I J'="{" F K=-1:0 S K=$O(^UTILITY($J,"SC",I,J,K)) Q:'K I $D(^UTILITY($J,"SC",1,I)),^(I) D HD1,I,SORT S I=2 ;IHS chgd this line and one below F D SCT S I=$O(^UTILITY($J,"SC",I)) Q:'I D ISC S J=0 F J1=0:0 D T:J'="{",AT:J="{" S J=$O(^UTILITY($J,"SC",I,J)) Q:J="" D:J="{" ADD I J'="{" F K=-1:0 S K=$O(^UTILITY($J,"SC",I,J,K)) Q:'K I $D(^UTILITY($J,"SC",1,I)),^(I) D HD1,I,SORT Q ;IHS/DSD/ENM 07/08/99 NEXT LINE COPIED/MODIFIED CLIN ;S J=0 F J1=0:0 D T S J=$O(^UTILITY($J,1,J)) Q:'J I $D(^UTILITY($J,"CL",1,J)),^(J) D HD1,I,SORT S J=0 F J1=0:0 D T S J=$O(^UTILITY($J,1,J)) Q:J="" I $D(^UTILITY($J,"CL",1,J)),^(J) D HD1,I,SORT Q SORT W !,J W:SDS="S"&K ?24,"***",I," IS THE CREDIT STOP CODE FOR THIS CLINIC***" F R=0:0 S R=$O(^UTILITY($J,1,J,R)) Q:'R D NM:SDNAM,PRINT Q ;IHS/DSD/ENM 11/23/99 NEXT LINE COPIED/MODIFIED NM ;S M=0 F M1=0:0 S M=$O(^UTILITY($J,1,J,R,"NM",M)) Q:'M S N=0 F N1=0:0 S N=$O(^UTILITY($J,1,J,R,"NM",M,N)) Q:'N F P=0:0 S P=$O(^UTILITY($J,1,J,R,"NM",M,N,P)) Q:'P S Q=0 F Q1=0:0 S Q=$O(^UTILITY($J,1,J,R,"NM",M,N,P,Q)) Q:'Q D PN S M=0 F M1=0:0 S M=$O(^UTILITY($J,1,J,R,"NM",M)) Q:M="" S N=0 F N1=0:0 S N=$O(^UTILITY($J,1,J,R,"NM",M,N)) Q:N="" F P=0:0 S P=$O(^UTILITY($J,1,J,R,"NM",M,N,P)) Q:'P S Q=0 F Q1=0:0 S Q=$O(^UTILITY($J,1,J,R,"NM",M,N,P,Q)) Q:Q="" D PN Q PN ;D:$Y>(IOSL-15) HD1 W !?14,$S(SDHR'=R:$S(SDF="D":$E(R,4,5)_"-"_$E(R,6,7)_"-"_$E(R,2,3),1:$E(R,4,5)_"-"_$E(R,2,3)),1:"") S SDHR=R W ?24,$E(M,1,17),?43,$E(N,1,3),"-",$E(N,4,5),"-",$E(N,6,9),?56,Q,?69,"TIME: " S Y=P X ^DD("DD") W $P(Y,"@",2) Q D:$Y>(IOSL-15) HD1 W !?14,$S(SDHR'=R:$S(SDF="D":$E(R,4,5)_"-"_$E(R,6,7)_"-"_$E(R,2,3),1:$E(R,4,5)_"-"_$E(R,2,3)),1:"") S SDHR=R W ?24,$E(M,1,20),?45,$J(N,8),?56,Q,?69,"TIME: " S Y=P X ^DD("DD") W $P(Y,"@",2) Q ;IHS chgd PRINT I $Y>(IOSL-12)&$S('SDNAM&(R>-1):1,'SDNAM:0,SDNAM&(M>-1):1,1:0) D HD1 W ! W:'SDNAM ?14,$S(SDF="D":$E(R,4,5)_"-"_$E(R,6,7)_"-"_$E(R,2,3),1:$E(R,4,5)_"-"_$E(R,2,3)) I SDNAM K Y S $P(Y,"_",57)="" W ?24,Y,! W ?30,$J(^UTILITY($J,1,J,R,"SD"),4),?36,$J(^("UN"),4),?42,$J(^("IN"),4),?48,$J(^("OB"),4),?55,"N/A",?60,$J(^("NS"),4),?66,$J(^("CA"),4),?76,$J(^("SD")+^("UN")+^("IN")+^("OB"),4) W:SDNAM ! S SDSCH=SDSCH+^UTILITY($J,1,J,R,"SD"),SDUN=SDUN+^("UN"),SDIN=SDIN+^("IN"),SDOB=SDOB+^("OB"),SDNS=SDNS+^("NS"),SDCA=SDCA+^("CA") S:SDS="S" SDSCS=SDSCS+^("SD"),SDSCU=SDSCU+^("UN"),SDSCI=SDSCI+^("IN"),SDSCO=SDSCO+^UTILITY($J,1,J,R,"OB"),SDSCN=SDSCN+^("NS"),SDSCC=SDSCC+^("CA") Q HD1 D LEG^SDCWL3 S SDPG=SDPG+1 W @IOF,!?29,"CLINIC WORKLOAD REPORT",?71,"PAGE: ",$J(SDPG,3),!?27,$S(SDF="D":"DETAILED BY DAY",1:"SUMMARY BY MONTH")," BY ",$S(SDS="C":"CLINIC",1:"STOP CODE"),!?21,"PERIOD COVERING: ",SDB,"-",SDE,!?25,"DATE RUN ON: ",SDNOW W !!?72,"TOTAL",!?29,"SCHED",?35,"UNSCH",?41,"INPAT",?47,"OVER-",?53,"ADD/",?59,"NO-",?65,"CANCEL",?72,"PATIENTS" W !,"CLINIC NAME",?14,"DATE",?29,"APPTS",?35,"APPTS",?41,"APPTS",?47,"BOOKS",?53,"EDITS",?59,"SHOWS",?65,"APPTS",?72,"SEEN",!! W:SDS="S" "STOP CODE:",?14,I Q I S (SDT,SDSCH,SDUN,SDIN,SDOB,SDNS,SDCA)=0 Q ISC S (SDAED,SDSCS,SDSCU,SDSCI,SDSCO,SDSCN,SDSCC)=0 Q T Q:$S('$D(^UTILITY($J,"CL",1,J)):1,'^(J):1,1:0) K Y S $P(Y,"_",67)="" W !!?14,Y,!?14,"Clinic Total",?30,$J(SDSCH,4),?36,$J(SDUN,4),?42,$J(SDIN,4),?48,$J(SDOB,4),?55,"N/A",?60,$J(SDNS,4),?66,$J(SDCA,4) S SDTOT=SDSCH+SDUN+SDIN+SDOB W ?76,$J(SDTOT,4) Q SCT Q:$S(I=2:1,'$D(^UTILITY($J,"SC",1,I)):1,'^(I):1,1:0) S SDTOT=SDSCS+SDSCU+SDSCI+SDSCO+$S('SDADD:0,1:SDAED) K Y S $P(Y,"_",81)="" W !!,Y,!,"Stop Code ",I," Total",?30,$J(SDSCS,4),?36,$J(SDSCU,4),?42,$J(SDSCI,4),?48,$J(SDSCO,4),?54,$J($S('SDADD:"N/A",1:SDAED),4),?60,$J(SDSCN,4),?66,$J(SDSCC,4),?76,$J(SDTOT,4) Q ADD D HD1 W !,"ADD/EDIT" S K=3 F K1=0:0 S SDHK=0,K=$O(^UTILITY($J,"SC",I,J,K)) Q:'K D ADD1:SDNAM,PRADD Q ADD1 S L=0 F L1=0:0 S L=$O(^UTILITY($J,"SC",I,J,K,L)) Q:'L S M=0 F M1=0:0 S M=$O(^UTILITY($J,"SC",I,J,K,L,M)) Q:'M F N=0:0 S N=$O(^UTILITY($J,"SC",I,J,K,L,M,N)) Q:'N F P=0:0 S P=$O(^UTILITY($J,"SC",I,J,K,L,M,N,P)) Q:'P D PA Q PA W !?14,$S(SDHK'=K:$S(SDF="D":$E(K,4,5)_"-"_$E(K,6,7)_"-"_$E(K,2,3),1:$E(K,4,5)_"-"_$E(K,2,3)),1:"") S SDHK=K W ?24,$E(L,1,17),?43,$E(M,1,3),"-",$E(M,4,5) W "-",$E(M,6,9),?56,"ADD/EDIT",?69,"TIME: " S Y=N X ^DD("DD") W $P(Y,"@",2) Q AT K Y S $P(Y,"_",67)="" W !?14,Y,!?14,"Add/Edit Total",?31,"N/A",?37,"N/A",?43,"N/A",?49,"N/A",?54,$J(SDAED,4),?61,"N/A",?67,"N/A",?76,$J(SDAED,4) Q PRADD D:($Y>(IOSL-8))&($O(^UTILITY($J,"SC",I,"{",K))'="") HD1 W ! W:'SDNAM ?14,$S(SDF="D":$E(K,4,5)_"-"_$E(K,6,7)_"-"_$E(K,2,3),1:$E(K,4,5)_"-"_$E(K,2,3)) I SDNAM K Y S $P(Y,"_",57)="" W ?24,Y,! S SDNUM=^UTILITY($J,"SC",I,"{",K) W ?31,"N/A",?37,"N/A",?43,"N/A",?49,"N/A",?54,$J(SDNUM,4),?61,"N/A",?67,"N/A",?76,$J(SDNUM,4) S SDAED=SDAED+SDNUM Q SDCWL2 SDCWL2 ; IHS/ADC/PDW/ENM - CONTINUATION OF CLINIC WORKLOAD REPORTS 5 MAY 88 ; [ 11/24/1999 2:43 PM ] ;;5.0;IHS SCHEDULING;**3**;MAR 25, 1999 ;;MAS VERSION 5.0; ;IHS/ANMC/RAM,LJF ; -- changed SSN to chart # ;IHS/HQW/KML 2/13/97 replace $N with $O w/o changing functionality ; PRO S SDAS=$S($P(^SC(I,"S",J,1,K,0),U,9)="C":"C",1:$P(^DPT(DFN,"S",J,0),U,2)) S SDP=$P(^DPT(DFN,"S",J,0),U,7) PRO1 S SDP=$P(^DPT(DFN,"S",J,0),U,7) S:SDS="C" ^(SDN)=$S($D(^UTILITY($J,"CL",'$D(SDFL),SDN)):^(SDN),1:0) I SDS="S" S:SDF1 ^(SDSC)=$S($D(^UTILITY($J,"SC",'$D(SDFL),SDSC)):^(SDSC),1:0) I SDF2 S ^(SDCR)=$S($D(^(SDCR)):^(SDCR),1:0) S $P(^UTILITY($J,"CL",'$D(SDFL),SDN),"^")=1 I SDS="S" S:SDF1 $P(^UTILITY($J,"SC",'$D(SDFL),SDSC),"^")=1 I SDF2 S $P(^UTILITY($J,"SC",'$D(SDFL),SDCR),"^")=1 I SDAS'["C",(SDAS'["N") S:SDS="C" $P(^(SDN),U,2)=$P(^UTILITY($J,"CL",'$D(SDFL),SDN),U,2)+1 I SDS="S" S:SDF1 $P(^(SDSC),U,2)=$P(^UTILITY($J,"SC",'$D(SDFL),SDSC),U,2)+1 I SDF2 S $P(^(SDCR),U,2)=$P(^UTILITY($J,"SC",'$D(SDFL),SDCR),U,2)+1 I $D(SDFL) S:SDS="C" ^(SDN)=$S($D(^UTILITY($J,"CL",1,SDN)):^(SDN),1:0) I SDS="S" S:SDF1 ^(SDSC)=$S($D(^UTILITY($J,"SC",1,SDSC)):^(SDSC),1:0) S:SDF2 ^(SDCR)=$S($D(^UTILITY($J,"SC",1,SDCR)):^(SDCR),1:0) Q:$D(SDFL)!(SDRT="B") S SDAPT=$S(SDF="D":J\1,1:J\100) S:'$D(^UTILITY($J,1,SDN,SDAPT)) (^(SDAPT,"CA"),^("NS"),^("IN"),^("OB"),^("UN"),^("SD"))=0 S SDSTAT=$S(SDAS["C":"CANCELLED",SDAS["N":"NO-SHOW",SDAS["I":"INPATIENT",SDOB:"OVERBOOK",SDP=4:"UNSCHEDULED",1:"SCHEDULED") ;S:SDNAM SDPN=$E($P(^DPT(DFN,0),U),1,20),SDSSN=$S($P(^(0),U,9)]"":$P(^(0),U,9),1:0),^UTILITY($J,1,SDN,SDAPT,"NM",SDPN,SDSSN,J,SDSTAT)="";IHS orig va S:SDNAM SDPN=$E($P(^DPT(DFN,0),U),1,20),SDSSN=$S($$HRC^ASDUT(DFN)]"":$$HRC^ASDUT(DFN),1:"?"),^UTILITY($J,1,SDN,SDAPT,"NM",SDPN,SDSSN,J,SDSTAT)="" ;IHS chgd I SDAS["C" S ^("CA")=^UTILITY($J,1,SDN,SDAPT,"CA")+1 Q I SDAS["N" S ^("NS")=^UTILITY($J,1,SDN,SDAPT,"NS")+1 Q I SDAS["I" S ^("IN")=^UTILITY($J,1,SDN,SDAPT,"IN")+1 Q I SDOB S ^("OB")=^UTILITY($J,1,SDN,SDAPT,"OB")+1 Q I SDP=4 S ^("UN")=^UTILITY($J,1,SDN,SDAPT,"UN")+1 Q S ^("SD")=^UTILITY($J,1,SDN,SDAPT,"SD")+1 Q PREV S SDBD=SDBD+.1,SDED=SDED-.9,SDBO=$E(SDBD,4,5)_"/"_$E(SDBD,6,7)_"/"_$E(SDBD,2,3),SDEO=$E(SDED,4,5)_"/"_$E(SDED,6,7)_"/"_$E(SDED,2,3),I=0,SDSUB=$S(SDS="C":"CL",1:"SC") D COMPHEAD ;IHS/DSD/ENM 11/24/99 NEXT LINE COPIED/MOD ;F I1=0:0 S I=$O(^UTILITY($J,SDSUB,1,I)) Q:'I S SDCUR=+$P(^(I),"^",2),SDOLD=+$S($D(^UTILITY($J,SDSUB,0,I)):$P(^(I),"^",2),1:0) D:($Y>(IOSL-8)) EOP,COMPHEAD D COMPARE F I1=0:0 S I=$O(^UTILITY($J,SDSUB,1,I)) Q:I="" S SDCUR=+$P(^(I),"^",2),SDOLD=+$S($D(^UTILITY($J,SDSUB,0,I)):$P(^(I),"^",2),1:0) D:($Y>(IOSL-8)) EOP,COMPHEAD D COMPARE D EOP Q COMPHEAD S SDPG=SDPG+1 W @IOF,!?29,"CLINIC WORKLOAD REPORT",?71,"PAGE: ",$J(SDPG,3),!?22,"COMPARISON OF VISITS TO PREVIOUS YEAR",!?20,"FOR PERIOD COVERING: ",SDB,"-",SDE,!?26,"REPORT RUN ON: ",SDNOW,!! K Y S $P(Y,"_",81)="" W Y D BLANK W !,"|",?25,"|",?29,"# OF VISITS",?43,"|",?47,"# OF VISITS",?61,"|",?64,"NET",?70,"|",?74,"%",?79,"|",!,"|",?7,$S(SDS="C":"Clinic",1:"Stop Code")," Name",?25,"|",SDB,"-",SDE,"|",SDBO,"-",SDEO,"| CHANGE | CHANGE |" D EOP,EOP,BLANK Q COMPARE W !,"|",$S(SDS="C":$E(I,1,24),1:$J(I,15)),?25,"|",?31,$J(SDCUR,7),?43,"|",?49,$J(SDOLD,7),?61,"|" S X=SDCUR-SDOLD W $J($S(X>0:"+"_X,2:X),7,2),?70,"|",$S(SDOLD=0:" N/A",1:$J(X*100/SDOLD,7,2))," |" Q EOP W !,"|" K Y S $P(Y,"_",25)="" W Y,"|",$E(Y,1,17),"|",$E(Y,1,17),"|",$E(Y,1,8),"|",$E(Y,1,8),"|" Q BLANK W !,"|",?25,"|",?43,"|",?61,"|",?70,"|",?79,"|" Q ADDON I 'SDALL&'$D(SDCL(SDSC)) Q S DIV=$S($P(^SDV(I,0),"^",3)]"":$P(^SDV(I,0),"^",3),1:$O(^DG(40.8,0))),DFN=$P(^SDV(I,0),U,2) Q:'VAUTD&'$D(VAUTD(DIV)) S $P(^UTILITY($J,"SC",'$D(SDFL),SDSC),"^")=1,$P(^(SDSC),"^",2)=$P(^(SDSC),"^",2)+1 Q:(SDRT="B") S ^("{")=$S($D(^(SDSC,"{")):^("{")+1,1:1),SDAPT=$S(SDF="D":I\1,1:I\100) Q:$D(SDFL) S ^(SDAPT)=$S($D(^UTILITY($J,"SC",SDSC,"{",SDAPT)):^(SDAPT)+1,1:1) ;Q:'SDNAM S SDNM=$P(^DPT(DFN,0),U),SDSSN=$S($P(^(0),U,9)]"":$P(^(0),U,9),1:0),^UTILITY($J,"SC",SDSC,"{",SDAPT,SDNM,SDSSN,I,J)="" Q;IHS orig va Q:'SDNAM S SDNM=$P(^DPT(DFN,0),U),HRCN=$$HRC^ASDUT(DFN) S:HRCN="" HRCN="?" S ^UTILITY($J,"SC",SDSC,"{",SDAPT,SDNM,HRCN,I,J)="" Q ;IHS chgd SDD SDD ; IHS/ADC/PDW/ENM - REMAP A CLINIC 26 JAN 84 3:00 pm ; [ 08/25/1999 4:43 PM ] ;;5.0;IHS SCHEDULING;**3**;MAR 25, 1999 ;;MAS VERSION 5.0; ;IHS/ANMC/RAM,LJF ; -- commented out intro text ;IHS/HQW/KML 2/13/97 replace $N with $O w/o changing functionality ; ;W !,"REMAP will set the patterns for the holiday if the clinic was set up",!,"to not schedule on Holidays",!,"REMAP should always be done if a clinic is changed from not scheduling",!,"on holidays to schedule on holidays" ;IHS commented out CL W !! D LO^DGUTL D ASK2^SDDIV G:Y<0 END S VAUTNI=1 D CLINIC^VAUTOMA G:Y<0 END DT D DATE^SDUTL G:POP END S DGVAR="SDBD^SDED^VAUTD#^VAUTC#^DUZ",DGPGM="START^SDD" D ZIS^DGUTQ G:POP END START D:'$D(DT) DT^SDUTL S (YP,PG,SD,SDU)=0,Y=DT X ^DD("DD") S DAT=Y D HD ;IHS/DSD/ENM 08/25/99 NEXT LINE COPIED/MODIFIED ;F SCI=0:0 S SD=$S(VAUTC:$O(^SC("B",SD)),1:$O(VAUTC(SD))) Q:'SD S SC=0 F SCC=0:0 S SC=$O(^SC("B",SD,SC)) Q:'SC S SD0=^SC(SC,0) I $P(SD0,U,3)="C" S SDNM=SD D SETX^SDD0 G:SDU END F SCI=0:0 S SD=$S(VAUTC:$O(^SC("B",SD)),1:$O(VAUTC(SD))) Q:SD="" S SC=0 F SCC=0:0 S SC=$O(^SC("B",SD,SC)) Q:'SC S SD0=^SC(SC,0) I $P(SD0,U,3)="C" S SDNM=SD D SETX^SDD0 G:SDU END END K %,%DT,DATE,DAY,DH,DOW,DR,DR1,HSI,I,P,POP,S,SB,SC,SDAPPT,SDAPPT1,SDBD,SDNM,SDED,SDHOL,SD0,SDIN,SDRE,SDRE1,SDSAVX,SDSL,SDSOH,SI,SM,SS,SD,SCI,SCC,ST,STARTDAY,STR,X,MSG,Y,YP,PG,DGVAR,DGPGM,VAUTD,VAUTC,SDU,BEGDATE,ENDDATE D CLOSE^DGUTQ Q ESC S SDU=0 I $E(IOST,1,2)="C-" W *7 R ESC:DTIME S:U=ESC SDU=1 HD U IO S PG=PG+1 W @IOF,!,DAT,?30,"Clinic Remap Function",?70,"pg ",PG,!!?5,"Clinic Name",?27,"Clinic Date",?50,"Remark",!?5,"-----------",?27,"-----------",?50,"------",! S YP=4 Q SDMULT0 SDMULT0 ; IHS/ADC/PDW/ENM - MAKE MULTI-CLINIC APPOINTMENTS 18 APR 86 ; [ 05/21/1999 10:13 AM ] ;;5.0;IHS SCHEDULING;**2**;DEC 03, 1998 ;;MAS VERSION 5.0; START W !,"The following clinics have been selected: ",! F I=0:0 S I=$O(SDC1(I)) Q:'I W !,$P(SDC1(I),"^",1),?45,+$P(SDC1(I),"^",2)," MINUTE APPOINTMENT" OK S %=1 W !!,"OK to proceed" D YN^DICN I '% W !,"RESPOND YES (Y) OR NO (N)" G OK G:(%-1) END W ! DT S %DT(0)=-SDMAX,%DT="AEF",%DT("A")="LOOK FOR CLINIC AVAILABILITY STARTING WHEN: " D ^%DT K %DT G:"^"[X END G:Y<0 DT S SDSTRTDT=+Y LIM W !,"SELECT LATEST DATE TO CHECK FOR AVAILABLE SLOTS: " S Y=SDMAX D DT^DIQ R "// ",X:DTIME G:X["^"!'($T) END I X']"" G OVR I X?.E1"?" W !," The latest date for future bookings (based on the limits from the selected",!," clinics) is: " S Y=SDMAX D DTS^SDUTL W Y," If you enter a date here, it must be less than this",!," date to further limit the search" G LIM S %DT="EF",%DT(0)=-SDMAX D ^%DT K %DT G:Y<0!(Y0 SDMAX=+Y OVR S SD1=0 F G1=0:0 S G1=$O(SDC(G1)),SD1=SD1+1 Q:'G1 D S1,AV Q:'FND S (SDSTRTDT,SDDT(SD1))=SDAPP A I 'FND W:'$D(SDNEXT) !,"No available slots found" W:'$D(SDNEXT) " on the same day in all the selected clinics for this",!," date range" G END I $D(SDNEXT) Q:SDNEXT G FND^SDMULT1 S SDNO=0 F I=2:1:SDCT I $D(SDDT(I)),$D(SDDT(I-1)),(SDDT(I)-SDDT(I-1)) S SDNO=1 Q I SDNO S SDSTRTDT=SDAPP G LOOKA D FND^SDMULT1 G END LOOKA S SD1=0 F G1=0:0 S G1=$O(SDC(G1)),SD1=SD1+1 Q:'G1 I SDDT(SD1)-SDSTRTDT D S1 D:SDSTRTDT'>SDMAX AV Q:'FND S (SDSTRTDT,SDDT(SD1))=SDAPP G A AV S SL=$S($D(^SC(SC,"SL")):^("SL"),1:"") I SL']"" W !,*7,"No 'SL' node defined - cannot proceed with this clinic" Q S X=$P(SL,U,6),SDSI=$S(X="":4,X<3:4,X:X,1:4),SDSOH=$P(SL,"^",8) S SDLEN=+SL,SDINC=$P(^SC(SC,"SL"),"^",6) S:SDINC="" SDINC=4 S SDSTR="123456789jklmnopqrstuvwxyz",SDINCM=$S(SDINC=4:15,SDINC=3:20,SDINC=6:10,SDINC=2:30,SDINC=1:60,1:0),SDNS=$S($D(SDC1(SC)):$P(SDC1(SC),"^",2),1:SDLEN)\SDINCM S:SDINC="" SDINC=4 S SDDIF=$S(SDINC<3:8/SDINC,1:2),SDINC=$S(SDINC<3:4,1:SDINC) K SDJ,SDAPP S (SDDOT,FND)=0 F J=0:1:6 I $D(^SC(+SC,"T"_J)) S SDJ(J)="" I '$D(SDJ),'$O(^SC(SC,"ST",SDSTRTDT)) Q S SDATE=$S($E(SDSTRTDT,6,7):SDSTRTDT,$E(SDSTRTDT,4,5):SDSTRTDT+1,1:SDSTRTDT+101) LOOP I '$D(SDJ),'$O(^SC(+SC,"ST",SDATE-1)) Q G:$D(^HOLIDAY(SDATE))&('SDSOH) NEXT I $D(^SC(+SC,"ST",SDATE,1)) S SDP=^(1) G CHECK S (X,SDATE1)=SDATE D DOW^SDM0 G:'$D(SDJ(Y)) NEXT S SDZ=$O(^SC(+SC,"T"_Y,0)) I SDZ>SDATE S SDATE1=SDZ ;IHS/DSD/ENM 05/20/99 ;ORIGINAL LINE ;S SDZ=$O(^SC(+SC,"T"_Y,SDATE1)) I 'SDZ!($S('$D(^SC(+SC,"T"_Y,SDZ,1)):1,^(1)']"":1,1:0))!(SDZ>SDATE) K:'SDZ!(SDZ>SDMAX) SDJ(Y) G NEXT ;S SDZ=$O(^SC(+SC,"T"_Y,SDATE1)) I '$G(SDZ)!(SDZ>SDATE) K:'SDZ!(SDZ>SDMAX) SDJ(Y) G NEXT S SDZ=$O(^SC(+SC,"T"_Y,SDATE1)) I $G(SDZ)']""!(SDZ>SDATE) K:'SDZ!(SDZ>SDMAX) SDJ(Y) G NEXT S ^SC(+SC,"ST",SDATE,1)=$E($P($T(DAY),U,Y+2),1,2)_" "_$E(SDATE,6,7)_$J("",SDSI+SDSI-6)_^SC(+SC,"T"_Y,SDZ,1),^SC(+SC,"ST",SDATE,0)=SDATE,SDAPP=SDATE,FND=0,SDP=^(1) CHECK S SDST=$F(SDP,"["),(CNT,FND)=0 F J=0:SDDIF:80 Q:$E(SDP,SDST+J,80)'["]" S K=$E(SDP,SDST+J),CNT=$S(K]""&(SDSTR[K):CNT+1,1:0) S:$S(SDSTR[K:0,K?1A!(K=0):0,1:1) STX=$F(SDP,"[",SDST+J),J=$S('STX:80,1:STX-SDDIF-SDST) I (CNT-SDNS)'<0 S SDAPP=SDATE,FND=1 Q Q:FND NEXT S SDDOT=SDDOT+1 W:'(SDDOT#5) "." S X1=SDATE,X2=1,X=X1+1 D:+$E(X,6,7)>28 C^%DTC S SDATE=X I SDATE'>SDMAX G LOOP Q DAY ;;^SUN^MON^TUES^WEDNES^THURS^FRI^SATUR S1 S A=SDC(G1),SC=+A,SDXXX=0 Q END I $S('$D(SDNEXT):1,'SDNEXT:1,1:0) K SB,SC,SDDIF,SDW,SDZ,SI,SL,STARTDAY,STR I $D(SDNEXT),$D(FND),'FND W !,"NO AVAILABILITY FOUND" K %,A,CNT,G1,I,K,LINE,LINE1,S,S1,SD,SD1,SDATE,SDATE1,SDC,SDC1,SDCT,SDDOT,SDDT,SDINC,SDINCM,SDJ,SDL,SDLEN,SDMADE,SDMAX,SDNO,SDNS,SDP,SDSI,SDSOH,SDSL,SDST,SDSTR,SDV,SDXXX,SM,SDSTRTDT,STM,X,X1,X2,Y,Y1,Z,ZZ D KVAR^VADPT K SDMLT1 W ! Q:$D(SDNEXT) G 1^SDMULT SDPURG SDPURG ; IHS/ADC/PDW/ENM - Purge Routine Parameter Selection ; [ 05/27/1999 9:58 AM ] ;;5.0;IHS SCHEDULING;**2**;MAR 25, 1999 ;;MAS VERSION 5.0; ;IHS/ANMC/RAM,LJF ; -- changed default on okay quesiton ; S:'$D(DTIME) DTIME=300 I '$D(DT) D DT^SDUTL ;beginning Y2K fix ;S SDLIM="2"_($E(DT,2,3)-$S($E(DT,4,5)>9:1,1:2))_"1001" S SDLIM=$E(DT,1,3)-$S($E(DT,4,5)>9:1,1:2)_"1001" ;IHS/DSD/ENM 05/27/99 ;end Y2K fix block W !,"The date you select to delete through may not exceed " S X1=SDLIM,X2=-1 D C^%DTC S (Y,SDLFY)=X D DT^DIQ W "." W !,"The files you may choose to delete from and the nodes that will be deleted are:",!!," from the HOSPITAL LOCATION File",!," - the 'S' nodes, APPOINTMENT multiple" W !," - the 'ST' nodes, clinic PATTERN multiple",!," - the 'OST' nodes, clinic SPECIAL PATTERN multiple",!," - the 'C' nodes, CHART CHECK multiple",!," - the 'AAS' nodes, 10/10 visits cross-reference" W !," from the PATIENT File",!," - the 'ASDPSD' nodes, Special Survey cross-reference",!," from the AMIS SAMPLE File",!," - the '1' nodes, VISIT DATE multiple",!," from the AMIS SAMPLE ERROR File",!," - all nodes" ;W !!,"OK to continue" S %=1 D YN^DICN Q:%<0!(%>1) I '% G SDPURG ;IHS orig va W !!,"OK to continue" S %=2 D YN^DICN Q:%<0!(%>1) I '% G SDPURG ;IHS chgd A1 S %=2 W !!,"Do you want to purge the Hospital Location file nodes" D YN^DICN Q:%<0 I '% W !,"Reply YES or NO" G A1 S SD44=$S('(%-1):1,1:0) A2 S %=2 W !!,"Do you want to purge the Patient file nodes" D YN^DICN Q:%<0 I '% W !,"Reply YES or NO" G A2 S SD2=$S('(%-1):1,1:0) A3 S %=2 W !!,"Do you want to purge the Amis Sample file and Amis Sample Error file nodes" D YN^DICN Q:%<0 I '% W !,"Reply YES or NO" G A3 S SDAS=$S('(%-1):1,1:0) I 'SD2,'SD44,'SDAS W !!,*7,"No files selected for purging --- NO PURGING DONE!!" G Q^SDPURG1 DT1 S Y=SDLFY D D^DIQ W !!,"Select date through which you want these files purged: ",Y," // " R X:DTIME Q:X["^" I X']"" S SDLIM1=SDLIM G OV I X?1"?".E W !,"This date may be different from the default - choose the date through which",!," you want to purge" G DT1 W ! S %DT="E",%DT(0)=-DT D ^%DT I Y'>0 W !,"Invalid date" G DT1 I Y>SDLFY W !,*7,"You can only purge data up to " S Y=SDLFY D DT^DIQ G DT1 K %DT S SDLIM1=+Y_.9 OV I 'SD2,'SD44,'SDAS W !!,*7,"No files selected for purging --- NO PURGING DONE!!" G Q^SDPURG1 A4 S %=2 W !!,"Do you want to print nodes (in GLOBAL format - %G) as they are deleted" D YN^DICN Q:%<0 I '% W !,"Reply YES or NO" G A4 S SDPR=$S('(%-1):1,1:0) A5 S %=1 W !!,"Is everything OK to proceed" D YN^DICN Q:%<0 I '% W !,"Reply YES or NO" G A5 I (%-1) W !,*7,"NO PURGING DONE!!" G Q^SDPURG1 S VAR="SDLIM^SDLIM1^SD44^SD2^SDAS^SDPR",VAL=SDLIM_"^"_SDLIM1_"^"_SD44_"^"_SD2_"^"_SDAS_"^"_SDPR,PGM="START^SDPURG1" D ZIS^DGUTQ G:POP Q^SDPURG1 G START^SDPURG1 SDRFC SDRFC ; IHS/ADC/PDW/ENM -XAK,BSN/GRR - RADIOLOGY PULL LIST 12/4/90 09:36 ; [ 10/28/1999 4:30 PM ] ;;5.0;IHS SCHEDULING;**3**;MAR 25, 1999 ;;MAS VERSION 5.0; ;IHS/HQW/KML 2/14/97 replace $N with $O w/o changing functionality S DIV="" D DIV^SDUTL I $T D RALST^SDDIV Q:Y<0 S U="^",%DT="AXE",%DT("A")="RADIOLOGY PULL LIST IN TERMINAL-DIGIT ORDER FOR WHAT DATE: " D ^%DT K %DT("A") Q:Y<0 S SDY=Y S PGM="START^SDRFC",VAR="DIV^SDY",VAL=DIV_"^"_SDY D ZIS^DGUTQ G:POP Q START S Y=SDY U IO K ^UTILITY($J) F C=0:0 S C=$O(^SC("ARAD",C)) Q:'C D CHECK I $T F SC="S","C" F D=Y-.01:0 S D=$O(^SC("ARAD",C,D)) Q:D\1-Y F P=0:0 S P=$O(^SC("ARAD",C,D,P)) Q:'P I $P(^(P),"^",1)'="N" S X=P D C:$D(^DPT(+X,0)) ;S DA=0 W @IOF,!?31,"RADIOLOGY PULL LIST",!?31,"Printed on: " D NOW^%DTC S Y=$E(%,1,12) D DT^DIQ--REMOVED @IOF--CRG 2/11/97 S DA=0 W !?31,"RADIOLOGY PULL LIST",!?31,"Printed on: " D NOW^%DTC S Y=$E(%,1,12) D DT^DIQ ;IHS/DSD/ENM 10/30/99 NEXT 2 LINES COPIED/MODIFIED ;F I=0:0 S DA=$O(^UTILITY($J,DA)) G Q:'DA S X=0,DA1=DA,J=0 D P G Q:'DA F I=0:0 S DA=$O(^UTILITY($J,DA)) G Q:DA="" S X=0,DA1=DA,J=0 D P G Q:DA="" P ;S X=$O(^UTILITY($J,DA,X)) Q:'X S DA1=DA,DFN=X,X=$O(^(X)),PAT1=^DPT(DFN,0) I 'X S DA=$O(^UTILITY($J,DA)) I 'DA S X=$O(^(DA,0)) S X=$O(^UTILITY($J,DA,X)) Q:X="" S DA1=DA,DFN=X,PAT1=^DPT(DFN,0) ;I X="" S DA=$O(^UTILITY($J,DA)) I DA="" S X=$O(^(DA,0)) S PAT2=$S(X>0:^DPT(X,0),1:"") W !!,$E($P(PAT1,"^",9),6,9)," ",$P(PAT1,"^",1),?40,$E($P(PAT2,"^",9),6,9)," ",$P(PAT2,"^",1),!!?6,$P(PAT1,"^",9),?46,$P(PAT2,"^",9) S AP1=$O(^UTILITY($J,DA1,DFN,0)),DAT1=^(AP1),AP2=$O(^UTILITY($J,DA,X,0)),DAT2=$S(AP2>0:^(AP2),1:"") W !!?6,$P(^SC(+DAT1,0),"^",1),?46,$S(AP2>0:$P(^SC(+DAT2,0),"^",1),1:"") W ! D O W ! F J=1:1 S:AP1>0 AP1=$O(^UTILITY($J,DA1,DFN,AP1)) Q:'AP1&('AP2) S:AP1>0 C=+^(AP1) S:AP2>0 AP2=$O(^UTILITY($J,DA,X,AP2)) S:AP2>0 C2=+^(AP2) D O W @$E("!!!!!!!!!!!!!",1,13-J) S J=0 G P Q W ! W:IOST'?1"C".E @IOF K DIV,Y,X,I,AP1,AP2,C,C2,D,DA,DA1,DAT1,DAT2,DFN,P,PAT1,PAT2,SC,SDY,T,J D CLOSE^DGUTQ Q ; C S DA=$E($P(^(0),U,9),6,9),DA=$E(DA,3,4)_$E(DA,1,2),X=$P(X_"^^^^^",U,1,5) I $D(^("S",D,0)),$P(^(0),U,2)["C" S X=X_"^***CANCELLED!***" S ^UTILITY($J," "_DA,+X,D)=C_U_X Q O I J=1 W !?6 W:AP1>0 "LATER APPOINTMENTS:" W:AP2>0 ?46,"LATER APPOINTMENTS:" W !?6 I AP1>0 S Y=AP1 D DTS^SDUTL W:'J Y S T=$P(AP1,".",2)_"000" W " ",$E(T,1,2),":",$E(T,3,4) W:J " ",$E($P(^SC(C,0),"^",1),1,25) I AP2>0 S Y=AP2 D DTS^SDUTL W:'J ?46,Y S T=$P(AP2,".",2)_"000" W ?46," ",$E(T,1,2),":",$E(T,3,4) W:J " ",$E($P(^SC(C2,0),"^",1),1,25) Q CHECK I $D(^SC(C,0)),$P(^(0),"^",3)="C",$S(DIV="":1,$P(^SC(C,0),"^",15)=DIV:1,1:0),$S('$D(^SC(C,"I")):1,+^("I")=0:1,+^("I")>Y:1,+$P(^("I"),"^",2)'>Y&(+$P(^("I"),"^",2)'=0):1,1:0) Q VADPT VADPT ;ALB/MRL/MJK - RETURN PATIENT VARIABLE ARRAYS [ 05/14/1999 9:37 AM ] ;;5.0;MAS VERSION 5.0;**1**;MAY 11, 1999 ;DFN = Patient IFN [if not passed entire array returned as null] ; DEM ;Demographic Variables ;S VAN=1,VAN(1)=10,VAV="VADM" D ^VADPT0 Q S VAN=1,VAN(1)=11,VAV="VADM" D ^VADPT0 Q ;IHS/ANMC/CLS 10/15/94 ; OPD ;Other Patient Data S VAN=2,VAN(1)=7,VAV="VAPD" D ^VADPT0 Q ; ADD ;Current Address S VAN=3,VAN(1)=10,VAV="VAPA" D ^VADPT0 Q ; OAD ;Other Patient Variables S VAN=4,VAN(1)=10,VAV="VAOA" D ^VADPT0 Q ; INP ;Inpatient Data [pre-version 5] ;IHS/DSD/ENM 05/11/99 ;S VAN=5,VAN(1)=10,VAV="VAIN" D ^VADPT0 Q S VAN=5,VAN(1)=11,VAV="VAIN" D ^VADPT0 Q ; IN5 ;Inpatient Data [v5.0 and above] S VAN=6,VAN(1)=17,VAV=$S('$D(VAIP("V")):"VAIP",VAIP("V")'?1A.E:"VAIP",1:VAIP("V")) D ^VADPT0 Q ; ELIG ;Eligibility Information S VAN=7,VAN(1)=9,VAV="VAEL" D ^VADPT0 Q ; MB ;Monetary Benefits S VAN=8,VAN(1)=9,VAV="VAMB" D ^VADPT0 Q ; SVC ;Service Information S VAN=9,VAN(1)=8,VAV="VASV" D ^VADPT0 Q ; REG ;Registration data S VAN=10,VAV="VARP" D ^VADPT0 Q ; SDE ;Enrollment Information S VAN=11,VAV="VAEN" D ^VADPT0 Q ; SDA ;Appointment Information S VAN=12,VAV="VASD" D ^VADPT0 Q ; PID ;Patient Id S VAN=13,VAV="VA" D ^VADPT0 Q ; V5 S X=$S($D(^DG(43,1,"VERSION")):+^("VERSION"),1:""),VADPT("V")=$S(X<5:0,1:1) K X Q OERR ; 1 S VATAG=1 D MULT Q 2 S VATAG=2 D MULT Q 3 S VATAG=3 D MULT Q 4 S VATAG=4 D MULT Q 5 S VATAG=5 D MULT Q 6 S VATAG=6 D MULT Q 7 S VATAG=7 D MULT Q 8 S VATAG=8 D MULT Q 9 S VATAG=9 D MULT Q 10 S VATAG=10 D MULT Q 51 S VATAG=11 D MULT Q 52 S VATAG=12 D MULT Q 53 S VATAG=13 D MULT Q ALL S VATAG=14 D MULT Q A5 S VATAG=15 D MULT Q SEL Q:$O(VARRAY(0))']"" S VATAG=0,VATAG(2)=$P($T(TAG),";;",2) F VATAG(1)=0:0 S VATAG=$O(VARRAY(VATAG)) Q:VATAG="" I VATAG(2)[("^"_VATAG_"^") S VARRAY(VATAG)=1,VAROOT=$S($D(VAROOT(VATAG)):VAROOT(VATAG),1:"") D @VATAG G Q ; MULT S VATAG=$P($T(TG+VATAG),";;",2) F VATAG(1)=1:1 S VATAG(2)=$P(VATAG,"^",VATAG(1)) Q:VATAG(2)="" S VAROOT=$S($D(VAROOT(VATAG(2))):VAROOT(VATAG(2)),1:"") D @(VATAG(2)) Q S VAROOT="" K VATAG Q ; KVA K VA KVAR D KVAR^VADPT0 K:$D(VAIP("V")) @(VAIP("V")) K I,X,Y,VARRAY,VADM,VAPD,VADPT,VAOA,VASV,VAEL,VAMB,VARP,VAEN,VASD,VAIN,VAIP,VAPA,VAHOW,VAINDT,VAERR,^UTILITY("VADPT",$J),VA200,VATEST Q ; TG ; ;;DEM^INP ;;DEM^ELIG ;;ELIG^INP ;;DEM^ADD ;;ADD^INP ;;DEM^ELIG^ADD ;;ELIG^SVC ;;ELIG^SVC^MB ;;DEM^REG^SDE^SDA ;;SDE^SDA ;;DEM^IN5 ;;ELIG^IN5 ;;ADD^IN5 ;;DEM^OPD^INP^ADD^ELIG^SVC^OAD^MB^REG^SDE^SDA ;;DEM^OPD^IN5^ADD^ELIG^SVC^OAD^MB^REG^SDE^SDA ; TAG ;;^DEM^OPD^INP^IN5^ADD^OAD^ELIG^SVC^MB^REG^SDE^SDA^