- 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
