10:14 AM  14-MAY-99
MAS Patch #1
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
 ;

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")="<CR> 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")="<CR> 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")="<CR> 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")="<CR> 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")="<CR> 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")="<CR> 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")="<CR> 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")="<CR> 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")="<CR> 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")="<CR> 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")="<CR> 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")="<CR> 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")="<CR> 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")="<CR> 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")="<CR> 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")="<CR> to Continue ""^"" to Exit" D ^DIR I Y'=1 G EXIT ;====>>
 D ^DGPM5
 S ^XTMP(MAS1,MASI)=1
 S DIR(0)="E",DIR("A")="<CR> 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")="<CR> to Continue ""^"" to Exit"
 D ^DIR
 I Y'=1 G EXIT
 D ^ADGGFL
 S DIR(0)="E",DIR("A")="<CR> to Continue ""^"" to Exit"
 I Y'=1 G EXIT
 D ^ADGCP
 S ^XTMP(MAS1,MASI)=1
 S DIR(0)="E",DIR("A")="<CR> 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")="<CR> 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")="<CR> 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")="<CR>" 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")="<CR> 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")="<CR> 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")="<CR> 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")="<CR> 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")="<CR> 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")="<CR> 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")="<CR> 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")="<CR> 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")="<CR> 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")="<CR> 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")="<CR> 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")="<CR> 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")="<CR> 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")="<CR> 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")="<CR> 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")="<CR> to Continue ""^"" to Exit" D ^DIR I Y'=1 G EXIT ;====>>
 D ^DGPM5
 S ^XTMP(MAS1,MASI)=1
 S DIR(0)="E",DIR("A")="<CR> 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")="<CR> to Continue ""^"" to Exit"
 D ^DIR
 I Y'=1 G EXIT
 D ^ADGGFL
 S DIR(0)="E",DIR("A")="<CR> to Continue ""^"" to Exit"
 I Y'=1 G EXIT
 D ^ADGCP
 S ^XTMP(MAS1,MASI)=1
 S DIR(0)="E",DIR("A")="<CR> 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")="<CR> 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")="<CR> 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")="<CR>" 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

SDC
SDC ; IHS/ADC/PDW/ENM - CANCEL A CLINIC'S AVAILABILITY 12 SEP 84 1:27 pm ;  [ 05/13/1999  2:46 PM ]
 ;;5.0;IHS SCHEDULING;**1**;MAR 25, 1999
 ;;MAS VERSION 5.0;
 ;IHS/ANMC/RAM,LJF
 ; -- gave user ability to put cancellation comments in
 ;IHS/HQW/KML 2/12/97 replace $N with $O w/o changing functionality
 ;
 K SDLT,SDCP S NOAP="" D LO^DGUTL
 S DIC=44,DIC(0)="MEQA",DIC("S")="I $P(^(0),""^"",3)=""C""",DIC("A")="Select CLINIC NAME: " D ^DIC K DIC("S"),DIC("A") G:'$D(^SC(+Y,"SL")) END^SDC0
 S SC=+Y,SL=^("SL"),%DT="AEXF",%DT("A")="CANCEL '"_$P(Y,U,2)_"' FOR WHAT DATE: " D ^%DT K %DT G:Y<0 END^SDC0
 S (SD,CDATE)=Y,%=$P(SL,U,6),SI=$S(%="":4,%<3:4,%:%,1:4),%=$P(SL,U,3),STARTDAY=$S(%:%,1:8) D NOW^%DTC S SDTIME=%
 K SDRE,SDIN,SDRE1 I $D(^SC(SC,"I")) S SDIN=+^("I"),SDRE=+$P(^("I"),"^",2),Y=SDRE D:Y DTS^SDUTL S SDRE1=$S(SDRE:" to "_Y,1:"")
 I $S('$D(SDIN):0,SDIN'>0!(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(X<ST:DH_$E(I,X+1+SI+SI),X=%:$S(Y="[":Y,1:DH)_$E(I,X+1+SI+SI),1:$S(Y="["&(X=ST):"]",1:"X")_"X"),Y=$S(DH="]":"",DH="[":DH,1:Y),I=$E(I,1,X-1+SI+SI)_P_$E(I,X+2+SI+SI,999)
 S:'$F(I,"[") I5=$F(I,"X"),I=$E(I,1,(I5-2))_"["_$E(I,I5,999) K I5
 S DH=0,^(1)=I,FR=FR-.0001 G C
S S ^("CAN")=^SC(SC,"ST",SD,1) Q
MESS R !,"MESSAGE: ",I:DTIME I I?1"?".E W !,"YOU MAY ENTER A MESSAGE CONCERNING THE CANCELLATION HERE" G MESS ;IHS added
 Q  ;IHS added
 ;
ALL ;D S S ^(1)="   "_$E(SD,6,7)_"    **CANCELLED**",FR=SD,TO=SD+.9 ;IHS orig va
 D S,MESS S ^(1)="   "_$E(SD,6,7)_"  *CANCELLED* "_I,FR=SD,TO=SD+.9 ;IHS chgd
C S FR=$O(^SC(SC,"S",FR)) I FR<1!(FR'<TO) W !!,"CANCELLED!  " K SDX G CHKEND^SDC0
 F I=0:0 S I=$O(^SC(SC,"S",FR,1,I)) Q:'I  S DFN=+^(I,0),$P(^(0),"^",9)="C" I $D(^DPT(DFN,"S",FR,0)),$P(^(0),"^",2)'["C" S $P(^(0),"^",2)="C",$P(^(0),"^",12)=DUZ,$P(^(0),"^",14)=SDTIME,DH=DH+1 D MORE
 G C
 ;
 ;IHS/DSD/ENM 05/11/99 NEXT LINE COPIED/MOD
B ;S X=SD D DOW^SDM0 S DOW=Y,SS=$O(^SC(SC,"T"_Y,X)) I $D(^(SS,1)),^(1)]"" S DH=^(1),DO=X+1,DA(1)=SC
 S X=SD D DOW^SDM0 S DOW=Y,SS=$O(^SC(SC,"T"_Y,X)) Q:'SS  I $D(^(SS,1)),^(1)]"" S DH=^(1),DO=X+1,DA(1)=SC
 Q
MORE I $D(^SC("ARAD",SC,FR,DFN)) S ^(DFN)="N"
 S SDIV=$S($P(^SC(SC,0),"^",15)]"":$P(^(0),"^",15),1:" 1"),SDV1=$S(SDIV:SDIV,1:$O(^DG(40.8,0))) I $D(^DPT("ASDPSD","C",SDIV,SC,FR,DFN)) K ^(DFN)
 S SDH=DH,SDTTM=FR,SDSC=SC,SDPL=I,SDRT="D" D RT^SDUTL
 S DH=SDH K SDH D CK1
 K SD1,SDIV,SDPL,SDRT,SDSC,SDTTM,SDX Q
CK1 S SDX=0 F SD1=FR\1:0 S SD1=$O(^DPT(DFN,"S",SD1)) Q:'SD1!(SD1\1-(FR\1))  I $P(^(SD1,0),"^",2)'["C",$P(^(0),"^",2)'["N" S SDX=1 Q
 Q:SDX  F SD1=2,4 I $D(^SC("AAS",SD1,FR\1,DFN)) S SDX=1 Q
 Q:SDX  I $D(^SDV("ADT",DFN)) F SD1=$P(FR,".")-1+.9999:0 S SD1=$O(^SDV("ADT",DFN,SD1)) Q:'SD1  I '(SD1-$P(FR,".")) S SDSCDT=^(SD1) I $D(^SDV(+SDSCDT,0)) S SDZ=1 K SDSCDT Q
 Q:SDX  K ^DPT("ASDPSD","B",SDIV,FR\1,DFN) 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^