SDDPA ;MAN/GRR,ALB/TMP - DISPLAY APPOINTMENTS ; 13 SEP 84 4:21 pm
;;5.3;PIMS;**140,334,1015,1016**;JUN 30, 2012;Build 20
D:'$D(DT) DT^SDUTL K SDACS
RD Q:$D(SDACS) S HDT=DT,APL="",SDRG=0,SDEDT=""
K ^UTILITY($J) W ! S SDEND=0,DIC="^DPT(",DIC(0)="AEQM" D ^DIC G:X=""!(X="^") END I Y<0 W !,*7,*7,"PATIENT NOT FOUND",*7,*7 G RD
S DA=+Y,DFN=DA,NAME=$P(Y,"^",2)
RD1 S %=1,DTOUT=0 W !,"Do you want to see only pending appointments" D YN^DICN G:%<0!$T RD I '% W !,"Respond YES or NO" G RD1
S (SDONE,POP)=0,SDYN=% D:SDYN=2 RANGE G:POP RD
S DGVAR="BEGDATE^ENDATE^SDYN^DFN^HDT^APL^SDRG^SDONE^SDEDT^SDEND",DGPGM="1^SDDPA" D ZIS^DGUTQ G:POP SDDPA D 1 G SDDPA
1 U IO S SDSTR=$S($D(^DPT(DFN,0)):^(0),1:""),SDN=$P(SDSTR,U)
S SDSSN=$P(SDSTR,U,9),%DT="R",X="N" D ^%DT
W !,"APPOINTMENTS FOR: ",$E(SDN,1,22)
W ?42,$E(SDSSN,1,3),"-",$E(SDSSN,4,5),"-",$E(SDSSN,6,9)
W ?54,"PRINTED: ",$$FMTE^XLFDT(Y,"5")
G:$O(^DPT(DFN,"S",HDT))'>0 NO S NDT=HDT,L=0
EN1 F J=1:1 S NDT=$O(^DPT(DFN,"S",NDT)) Q:NDT'>0!(SDRG&(NDT>SDEDT)) I $S($P(^(NDT,0),"^",2)']"":1,$P(^(0),"^",2)["NT":1,$P(^(0),"^",2)["I":1,SDRG:1,1:0) D CHKSO,FLEN S ^UTILITY($J,L)=NDT_"^"_SC_"^"_COV_"^"_APL_"^^"_SDNS_"^"_SDBY
G:L'>0 NO F ZZ=1:1:L S AT=$S($P(^UTILITY($J,ZZ),"^",2)'?.N:1,1:0) W !! S Y=$P($P(^(ZZ),"^",1),".",1) D DT^SDM0 S X=$P(^(ZZ),"^",1) X ^DD("FUNC",2,1) W " ",$J(X,8) D MORE Q:SDEND
G END
;
NO W !,"NO ",$S('SDRG:"PENDING APPOINTMENTS",1:"APPOINTMENTS FOUND DURING RANGE SELECTED")
G END
RANGE D DATE^SDUTL Q:POP S HDT=BEGDATE,SDEDT=ENDDATE_.9,SDRG=1,SDONE=0
I $D(^DPT(DFN,"ARCH","AB","S")) S X=$O(^("S",0)) I $D(^DPT(DFN,"ARCH",X)) F A=0:0 S A=$O(^DPT(DFN,"ARCH",X,1,A)) Q:A'>0 S Z=^(A,0),B=$P(Z,"^",3),C=$P(Z,"^",4),D=$P(Z,"^",5),E=$P(Z,"^",2) I B'<HDT&(B'>SDEDT)!(C'<HDT&(C'>SDEDT)) D ARCH
Q
ARCH I 'SDONE W @IOF,!!,"This patient has archived appts during this time period:",! W !,?3,"ARCHIVED DATE RANGE # APPOINTMENTS TAPE # DATE ARCHIVED",!
W !,?3,$S(B:$$FMTE^XLFDT(B,"5D"),1:""),"-",$S(C:$$FMTE^XLFDT(C,"5D"),1:""),?32,+D,?45,E S Y=+Z D DTS^SDUTL W ?59,Y
S SDONE=1 K B,C,D,E,Z Q
FLEN ;following code changed with SD/545
S SC=+^DPT(DFN,"S",NDT,0),L=L+1,COV=$S($P(^DPT(DFN,"S",NDT,0),U,11)=1:" (COLLATERAL) ",1:"") I $D(^SC(SC,"S",NDT)) F ZL=0:0 S ZL=$O(^SC(SC,"S",NDT,1,ZL)) Q:ZL="" D
.N POP S POP=0
.I '$D(^SC(SC,"S",NDT,1,ZL,0)) I $D(^SC(SC,"S",NDT,1,ZL,"C")) D RESET I POP S APL=APLEN Q
.I +^SC(SC,"S",NDT,1,ZL,0)=DFN S APL=$P(^SC(SC,"S",NDT,1,ZL,0),U,2)
K POP,APLEN
Q
;
RESET ;reset zero node of appt multiple in file #44 if values are known SD/545
I 'DFN S POP=1 Q
I '$D(^DPT(DFN,"S",NDT,0)) S POP=1 Q
I '$G(^DPT(DFN,"S",NDT,0)) S POP=1 Q
I '+^DPT(DFN,"S",NDT,0) S POP=1 Q
I $P(^DPT(DFN,"S",NDT,0),U,2)="CA"!($P(^(0),U,2)="PC")!($P(^(0),U,2)="PCA") K ^SC(SC,"S",NDT,1,ZL,"C") S APLEN=+^SC(SC,"SL"),POP=1 Q
S (NODE,APLEN,STAT1)=""
S NODE=^DPT(DFN,"S",NDT,0),APLEN=+^SC(SC,"SL"),STAT1=$P(NODE,U,2)
S DA=ZL,DA(1)=NDT,DA(2)=SC
S DIE="^SC("_DA(2)_",""S"","_DA(1)_",1,"
S DR=".01///^S X=DFN;1///^S X=APLEN" D ^DIE
S SC=DA(2)
S $P(^SC(SC,"S",NDT,1,ZL,0),U,6)=$P(NODE,U,18)
S $P(^SC(SC,"S",NDT,1,ZL,0),U,7)=$P(NODE,U,19)
I STAT1="C" S $P(^SC(SC,"S",NDT,1,ZL,0),U,9)=STAT1
K NODE,APLEN,STAT1,DA,DR,DIE
Q
;
CHKSO S SDNS=$S($P(^DPT(DFN,"S",NDT,0),"^",2)']""!($P(^(0),"^",2)["I"):"",1:$P(^(0),"^",2)),SDBY="" I SDNS["C" S SDU=+$P(^DPT(DFN,"S",NDT,0),"^",12),SDBY=$S($D(^VA(200,SDU,0)):$P(^(0),"^",1),1:SDU) K SDU
F SDJ=3,4,5 I $P(^DPT(DFN,"S",NDT,0),"^",SDJ)]"" S L=L+1,^UTILITY($J,L)=$P(^(0),"^",SDJ)_"^"_$S(SDJ=3:"LAB",SDJ=4:"XRAY",1:"EKG")_"^0^0"
Q
END W ! K %DT,A,C,APL,AT,BEGDATE,ENDDATE,COV,DA,DFN,DGPGM,DGVAR,DIPGM,DIC,HDT,J,L,NAME,NDT,POP,SC,SDED,SDBD,SDBY,SDEDT,SDEND,SDJ,SDN,SDNS,SDONE,SDRG,SDSSN,SDSTR,SDYN,X,Y,ZL,ZX,ZZ,^UTILITY($J) D CLOSE^DGUTQ Q
MORE I AT W ?36,$P(^UTILITY($J,ZZ),"^",2) I ($Y+4)>IOSL,$E(IOST,1,2)="C-" D OUT^SDUTL Q:SDEND W @IOF
Q:AT
W " (",$P(^UTILITY($J,ZZ),"^",4)," MINUTES) ",$S($D(^SC(+$P(^UTILITY($J,ZZ),"^",2),0)):$P(^SC(+$P(^UTILITY($J,ZZ),"^",2),0),"^"),1:"Deleted Clinic"),$P(^UTILITY($J,ZZ),"^",3)," ",$P(^(ZZ),"^",5)
I $P(^(ZZ),"^",6)]"" W !,$S($P(^(ZZ),"^",6)["NT":" *** ACTION REQUIRED ***",$P(^(ZZ),"^",6)["N":" *** NO-SHOW ***",$P(^(ZZ),"^",6)["C":" *** CANCELLED BY "_$P(^(ZZ),"^",7)_" ***",1:"") ;NAKED REFERENCE - ^UTILITY($J,ZZ)
I ($Y+4)>IOSL,IOST?1"C-".E D OUT^SDUTL W:'SDEND @IOF
Q
SDDPA ;MAN/GRR,ALB/TMP - DISPLAY APPOINTMENTS ; 13 SEP 84 4:21 pm
+1 ;;5.3;PIMS;**140,334,1015,1016**;JUN 30, 2012;Build 20
+2 IF '$DATA(DT)
DO DT^SDUTL
KILL SDACS
RD IF $DATA(SDACS)
QUIT
SET HDT=DT
SET APL=""
SET SDRG=0
SET SDEDT=""
+1 KILL ^UTILITY($JOB)
WRITE !
SET SDEND=0
SET DIC="^DPT("
SET DIC(0)="AEQM"
DO ^DIC
IF X=""!(X="^")
GOTO END
IF Y<0
WRITE !,*7,*7,"PATIENT NOT FOUND",*7,*7
GOTO RD
+2 SET DA=+Y
SET DFN=DA
SET NAME=$PIECE(Y,"^",2)
RD1 SET %=1
SET DTOUT=0
WRITE !,"Do you want to see only pending appointments"
DO YN^DICN
IF %<0!$TEST
GOTO RD
IF '%
WRITE !,"Respond YES or NO"
GOTO RD1
+1 SET (SDONE,POP)=0
SET SDYN=%
IF SDYN=2
DO RANGE
IF POP
GOTO RD
+2 SET DGVAR="BEGDATE^ENDATE^SDYN^DFN^HDT^APL^SDRG^SDONE^SDEDT^SDEND"
SET DGPGM="1^SDDPA"
DO ZIS^DGUTQ
IF POP
GOTO SDDPA
DO 1
GOTO SDDPA
1 USE IO
SET SDSTR=$SELECT($DATA(^DPT(DFN,0)):^(0),1:"")
SET SDN=$PIECE(SDSTR,U)
+1 SET SDSSN=$PIECE(SDSTR,U,9)
SET %DT="R"
SET X="N"
DO ^%DT
+2 WRITE !,"APPOINTMENTS FOR: ",$EXTRACT(SDN,1,22)
+3 WRITE ?42,$EXTRACT(SDSSN,1,3),"-",$EXTRACT(SDSSN,4,5),"-",$EXTRACT(SDSSN,6,9)
+4 WRITE ?54,"PRINTED: ",$$FMTE^XLFDT(Y,"5")
+5 IF $ORDER(^DPT(DFN,"S",HDT))'>0
GOTO NO
SET NDT=HDT
SET L=0
EN1 FOR J=1:1
SET NDT=$ORDER(^DPT(DFN,"S",NDT))
IF NDT'>0!(SDRG&(NDT>SDEDT))
QUIT
IF $SELECT($PIECE(^(NDT,0),"^",2)']"":1,$PIECE(^(0),"^",2)["NT":1,$PIECE(^(0),"^",2)["I":1,SDRG:1,1:0)
DO CHKSO
DO FLEN
SET ^UTILITY($JOB,L)=NDT_"^"_SC_"^"_COV_"^"_APL_"^^"_SDNS_"^"_SDBY
+1 IF L'>0
GOTO NO
FOR ZZ=1:1:L
SET AT=$SELECT($PIECE(^UTILITY($JOB,ZZ),"^",2)'?.N:1,1:0)
WRITE !!
SET Y=$PIECE($PIECE(^(ZZ),"^",1),".",1)
DO DT^SDM0
SET X=$PIECE(^(ZZ),"^",1)
XECUTE ^DD("FUNC",2,1)
WRITE " ",$JUSTIFY(X,8)
DO MORE
IF SDEND
QUIT
+2 GOTO END
+3 ;
NO WRITE !,"NO ",$SELECT('SDRG:"PENDING APPOINTMENTS",1:"APPOINTMENTS FOUND DURING RANGE SELECTED")
+1 GOTO END
RANGE DO DATE^SDUTL
IF POP
QUIT
SET HDT=BEGDATE
SET SDEDT=ENDDATE_.9
SET SDRG=1
SET SDONE=0
+1 IF $DATA(^DPT(DFN,"ARCH","AB","S"))
SET X=$ORDER(^("S",0))
IF $DATA(^DPT(DFN,"ARCH",X))
FOR A=0:0
SET A=$ORDER(^DPT(DFN,"ARCH",X,1,A))
IF A'>0
QUIT
SET Z=^(A,0)
SET B=$PIECE(Z,"^",3)
SET C=$PIECE(Z,"^",4)
SET D=$PIECE(Z,"^",5)
SET E=$PIECE(Z,"^",2)
IF B'<HDT&(B'>SDEDT)!(C'<HDT&(C'>SDEDT))
DO ARCH
+2 QUIT
ARCH IF 'SDONE
WRITE @IOF,!!,"This patient has archived appts during this time period:",!
WRITE !,?3,"ARCHIVED DATE RANGE # APPOINTMENTS TAPE # DATE ARCHIVED",!
+1 WRITE !,?3,$SELECT(B:$$FMTE^XLFDT(B,"5D"),1:""),"-",$SELECT(C:$$FMTE^XLFDT(C,"5D"),1:""),?32,+D,?45,E
SET Y=+Z
DO DTS^SDUTL
WRITE ?59,Y
+2 SET SDONE=1
KILL B,C,D,E,Z
QUIT
FLEN ;following code changed with SD/545
+1 SET SC=+^DPT(DFN,"S",NDT,0)
SET L=L+1
SET COV=$SELECT($PIECE(^DPT(DFN,"S",NDT,0),U,11)=1:" (COLLATERAL) ",1:"")
IF $DATA(^SC(SC,"S",NDT))
FOR ZL=0:0
SET ZL=$ORDER(^SC(SC,"S",NDT,1,ZL))
IF ZL=""
QUIT
Begin DoDot:1
+2 NEW POP
SET POP=0
+3 IF '$DATA(^SC(SC,"S",NDT,1,ZL,0))
IF $DATA(^SC(SC,"S",NDT,1,ZL,"C"))
DO RESET
IF POP
SET APL=APLEN
QUIT
+4 IF +^SC(SC,"S",NDT,1,ZL,0)=DFN
SET APL=$PIECE(^SC(SC,"S",NDT,1,ZL,0),U,2)
End DoDot:1
+5 KILL POP,APLEN
+6 QUIT
+7 ;
RESET ;reset zero node of appt multiple in file #44 if values are known SD/545
+1 IF 'DFN
SET POP=1
QUIT
+2 IF '$DATA(^DPT(DFN,"S",NDT,0))
SET POP=1
QUIT
+3 IF '$GET(^DPT(DFN,"S",NDT,0))
SET POP=1
QUIT
+4 IF '+^DPT(DFN,"S",NDT,0)
SET POP=1
QUIT
+5 IF $PIECE(^DPT(DFN,"S",NDT,0),U,2)="CA"!($PIECE(^(0),U,2)="PC")!($PIECE(^(0),U,2)="PCA")
KILL ^SC(SC,"S",NDT,1,ZL,"C")
SET APLEN=+^SC(SC,"SL")
SET POP=1
QUIT
+6 SET (NODE,APLEN,STAT1)=""
+7 SET NODE=^DPT(DFN,"S",NDT,0)
SET APLEN=+^SC(SC,"SL")
SET STAT1=$PIECE(NODE,U,2)
+8 SET DA=ZL
SET DA(1)=NDT
SET DA(2)=SC
+9 SET DIE="^SC("_DA(2)_",""S"","_DA(1)_",1,"
+10 SET DR=".01///^S X=DFN;1///^S X=APLEN"
DO ^DIE
+11 SET SC=DA(2)
+12 SET $PIECE(^SC(SC,"S",NDT,1,ZL,0),U,6)=$PIECE(NODE,U,18)
+13 SET $PIECE(^SC(SC,"S",NDT,1,ZL,0),U,7)=$PIECE(NODE,U,19)
+14 IF STAT1="C"
SET $PIECE(^SC(SC,"S",NDT,1,ZL,0),U,9)=STAT1
+15 KILL NODE,APLEN,STAT1,DA,DR,DIE
+16 QUIT
+17 ;
CHKSO SET SDNS=$SELECT($PIECE(^DPT(DFN,"S",NDT,0),"^",2)']""!($PIECE(^(0),"^",2)["I"):"",1:$PIECE(^(0),"^",2))
SET SDBY=""
IF SDNS["C"
SET SDU=+$PIECE(^DPT(DFN,"S",NDT,0),"^",12)
SET SDBY=$SELECT($DATA(^VA(200,SDU,0)):$PIECE(^(0),"^",1),1:SDU)
KILL SDU
+1 FOR SDJ=3,4,5
IF $PIECE(^DPT(DFN,"S",NDT,0),"^",SDJ)]""
SET L=L+1
SET ^UTILITY($JOB,L)=$PIECE(^(0),"^",SDJ)_"^"_$SELECT(SDJ=3:"LAB",SDJ=4:"XRAY",1:"EKG")_"^0^0"
+2 QUIT
END WRITE !
KILL %DT,A,C,APL,AT,BEGDATE,ENDDATE,COV,DA,DFN,DGPGM,DGVAR,DIPGM,DIC,HDT,J,L,NAME,NDT,POP,SC,SDED,SDBD,SDBY,SDEDT,SDEND,SDJ,SDN,SDNS,SDONE,SDRG,SDSSN,SDSTR,SDYN,X,Y,ZL,ZX,ZZ,^UTILITY($JOB)
DO CLOSE^DGUTQ
QUIT
MORE IF AT
WRITE ?36,$PIECE(^UTILITY($JOB,ZZ),"^",2)
IF ($Y+4)>IOSL
IF $EXTRACT(IOST,1,2)="C-"
DO OUT^SDUTL
IF SDEND
QUIT
WRITE @IOF
+1 IF AT
QUIT
+2 WRITE " (",$PIECE(^UTILITY($JOB,ZZ),"^",4)," MINUTES) ",$SELECT($DATA(^SC(+$PIECE(^UTILITY($JOB,ZZ),"^",2),0)):$PIECE(^SC(+$PIECE(^UTILITY($JOB,ZZ),"^",2),0),"^"),1:"Deleted Clinic"),$PIECE(^UTILITY($JOB,ZZ),"^",3)," ",$PIECE(^(ZZ),"^",5)
+3 ;NAKED REFERENCE - ^UTILITY($J,ZZ)
IF $PIECE(^(ZZ),"^",6)]""
WRITE !,$SELECT($PIECE(^(ZZ),"^",6)["NT":" *** ACTION REQUIRED ***",$PIECE(^(ZZ),"^",6)["N":" *** NO-SHOW ***",$PIECE(^(ZZ),"^",6)["C":" *** CANCELLED BY "_$PIECE(^(ZZ),"^",7)_" ***",1:"")
+4 IF ($Y+4)>IOSL
IF IOST?1"C-".E
DO OUT^SDUTL
IF 'SDEND
WRITE @IOF
+5 QUIT
