3:32 PM 25-JUN-99 MAS Patch #2 routines. 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 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 ; [ 05/17/1999 2:38 PM ] ;;5.0;ADMISSION/DISCHARGE/TRANSFER;**2**;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 Q (DGA(3,6)+DGA(1,6))/(DGA(1,3)+DGA(1,4)+DGA(3,3)+DGA(3,4)) ; 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 ; [ 05/17/1999 2:44 PM ] ;;5.0;ADMISSION/DISCHARGE/TRANSFER;**2**;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 Q (DGA(3,6)+DGA(1,6))/(DGA(1,3)+DGA(1,4)+DGA(3,3)+DGA(3,4)) ; 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") 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)_" " 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 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 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 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^