- DGPASS ;ALB/JDS - ABSENCE LIST ; 01 JAN 86 @0800
- ;;5.3;Registration;**162**;Aug 13, 1993
- ;
- EN D QUIT S %DT="AEPT",%DT("A")="Enter date of Absence: " D ^%DT G:Y'>0 QUIT G EN:+Y>(DT+1) S DGT=+Y,DG2=DGT,DGT=$S(DGT[".":DGT,1:DGT_".2400"),DG2=DGT
- S DGVAR="DGT^DG2",DGPGM="START^DGPASS" D ZIS^DGUTQ I 'POP U IO D START^DGPASS
- QUIT D CLOSE^DGUTQ G QUIT1^DGOASIH
- START D NOW^%DTC S Y=$E(%,1,12) S DGTIME=$$FMTE^XLFDT(Y,1) S $P(DGCL,"-",81)=""
- S X1=DGT,X2=-32 D C^%DTC S DGSTART=X
- S Y=DGT\1 X ^DD("DD") S DGDAY=Y
- S DGFL=0 D EEN I '$D(^UTILITY($J,"DG")) W !!?8,"*** THERE ARE NO PATIENTS OUT ON ABSENCE FOR "_DGDAY_" ***" G QUIT
- D WR G QUIT
- ;
- EEN S DGA="^25^26^43^44^45^13^1^2^3^" D NOW^%DTC S DGNOW=%
- S DGDAT=DGT
- F DGDT=DGSTART:0 S DGDT=$O(^DGPM("AMV2",DGDT)) Q:'DGDT!(DGDT>DGDAT) F DFN=0:0 S DFN=$O(^DGPM("AMV2",DGDT,DFN)) Q:'DFN F DGIFN=0:0 S DGIFN=$O(^DGPM("AMV2",DGDT,DFN,DGIFN)) Q:'DGIFN D CK
- Q
- CK ;check to see if xfr to absence
- Q:'$D(^DGPM(+DGIFN,0)) S DGX=^(0),DGCA=$P(DGX,"^",14)
- Q:'$D(^DGPM(+DGCA,0))
- I DGA'[("^"_$P(DGX,"^",18)_"^") Q ;not mvt to absence
- S DGFL=0 ;DGFL=1 if patient returned from absence
- S DGFL=0 F DGI=DGDT+.0000005:0 S DGI=$O(^DGPM("APCA",DFN,DGCA,DGI)) Q:'DGI!(DGI>DGDAT) S DGJ=$O(^DGPM("APCA",DFN,DGCA,+DGI,0)) I $D(^DGPM(+DGJ,0)) S DGY=^(0) D OUT
- I 'DGFL D SET
- Q
- SET S VAIP("D")=DGDAT D IN5^VADPT S:VAIP(1)']"" DGFL=1 Q:VAIP(1)']"" S DGADM=VAIP(1) I $D(^DGPM(DGADM,0)) S $P(DGX,"^",5)=$P(^DGPM(DGADM,0),"^",5),$P(DGX,"^",6)=$P(^DGPM(DGADM,0),"^",6),$P(DGX,"^",13)=$P(^DGPM(DGADM,0),"^",13)
- Q:$P(^DGPM(DGADM,0),"^",6)']"" S DGDV=$P(^DIC(42,+$P(^DGPM(DGADM,0),"^",6),0),"^",11) S DGDV=$S(DGDV]"":$P(^DG(40.8,DGDV,0),"^"),1:"ZUNKNOWN"),DGP=$P(^DPT(DFN,0),"^",1)
- D PID^VADPT6
- S DGTYP=$P(DGX,"^",18),DGTP=$S(DGTYP=1:"PASS",DGTYP=2!(DGTYP=26):"AA",DGTYP=3!(DGTYP=25):"UA",DGTYP=13!(DGTYP=43)!(DGTYP=44)!(DGTYP=45):"ASIH",1:""),DGCD=0,X=+DGX\1 D:X]"" DAT S:DGCD DGLV=DGCD
- I "^25^26^"[("^"_+VAIP(4)_"^") S DGTP=$S(+VAIP(4)=25:"UA",1:"AA")
- S DGCD=0 S X=$S($P(DGX,"^",13):$P(DGX,"^",13),1:"") D:X]"" DAT S DGRT=$S(DGCD:DGCD,1:"")
- S DGW=$S($P(DGX,"^",5)]""&($P(DGX,"^",5)'?.N):$P(DGX,"^",5),$P(DGX,"^",5)]""&($P(DGX,"^",5)?.N):$P(^DIC(4,$P(DGX,"^",5),0),"^",1),1:$P(^DIC(42,$P(DGX,"^",6),0),"^"))
- I DGFL Q ;already returned...don't store
- I $D(DGDFN(DFN)) Q ;patient already stored once
- I $D(DGASIH) S DGDFN(DFN)=DFN,^UTILITY($J,"DG",DGDV,DGP,DFN)=VA("PID")_"^"_DGLV_"^"_DGW Q
- S DGDFN(DFN)=DFN,^UTILITY($J,"DG",DGDV,DGP,DFN)=VA("PID")_"^"_DGTP_"^"_DGLV_"^"_DGRT_"^"_DGW S (VA("PID"),DGTP,DGLV,DGRT,DGW)=""
- Q
- ;
- OUT ;check to see if patient returned from absence - DGFL=1 if yes
- S DGTYP=$P(DGY,"^",18)
- I $P(DGY,"^",2)=3,(DGTYP'=42),+DGY<DGDAT S DGFL=1 Q
- I $P(DGY,"^",2)=3,(DGTYP'=41),+DGY<DGDAT S DGFL=1 Q
- I "^14^22^23^24^"[("^"_DGTYP_"^"),+DGY<DGDAT S DGFL=1 Q
- I DGNOW<+DGY Q ;future movement...ignore
- I DGTYP=42,+DGY<DGDAT S DGFL=1 Q ;if WHILE ASIH and not future...
- Q
- DAT S DGCD=$E(X,4,5)_"-"_$E(X,6,7)_"-"_(1700+$E(X,1,3)) Q
- HEAD S DGPG=DGPG+1 W @IOF,!,"ABSENCE LIST FOR ",DGDAY,?40,"PRINTED: ",DGTIME,?72," PAGE: "_DGPG
- W !!,"NAME",?22,"PT ID",?36,"TYPE",?42,"LEAVE",?54,"RETURN",?66,"WARD"
- W !,DGCL,!!,?10,"DIVISION: ",$S(DGDV="ZUNKNOWN":"UNKNOWN",1:DGDV),!
- Q
- WR S (DGU,DGDV,DGFL,DGP)=0
- F DGD=0:0 S DGDV=$O(^UTILITY($J,"DG",DGDV)) Q:DGDV=""!(DGU) S DGPG=0 D:DGFL RT Q:DGU D HEAD F M=0:0 S DGP=$O(^UTILITY($J,"DG",DGDV,DGP)) Q:DGP=""!(DGU) D WRCNT
- W ! Q
- WRCNT F DFN=0:0 S DFN=$O(^UTILITY($J,"DG",DGDV,DGP,DFN)) Q:'DFN!(DGU) S DGNO=^UTILITY($J,"DG",DGDV,DGP,DFN) D WR1 S DGFL=1
- Q
- WR1 I $Y+4>IOSL D:IOST?1"C-".E RT Q:DGU D HEAD
- W !,$E(DGP,1,20),?22,$P(DGNO,"^"),?36,$P(DGNO,"^",2),?42,$P(DGNO,"^",3),?54,$P(DGNO,"^",4),?66,$E($P(DGNO,"^",5),1,14) Q
- RT Q:IOST'?1"C-".E
- F X=$Y:1:(IOSL-2) W !
- R !?22,"Enter <RET> to continue or ^ to Quit",X:DTIME S:X["^"!('$T) DGU=1 Q:DGU=1
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPASS 3907 printed Feb 19, 2025@00:13:15 Page 2
- DGPASS ;ALB/JDS - ABSENCE LIST ; 01 JAN 86 @0800
- +1 ;;5.3;Registration;**162**;Aug 13, 1993
- +2 ;
- EN DO QUIT
- SET %DT="AEPT"
- SET %DT("A")="Enter date of Absence: "
- DO ^%DT
- if Y'>0
- GOTO QUIT
- if +Y>(DT+1)
- GOTO EN
- SET DGT=+Y
- SET DG2=DGT
- SET DGT=$SELECT(DGT[".":DGT,1:DGT_".2400")
- SET DG2=DGT
- +1 SET DGVAR="DGT^DG2"
- SET DGPGM="START^DGPASS"
- DO ZIS^DGUTQ
- IF 'POP
- USE IO
- DO START^DGPASS
- QUIT DO CLOSE^DGUTQ
- GOTO QUIT1^DGOASIH
- START DO NOW^%DTC
- SET Y=$EXTRACT(%,1,12)
- SET DGTIME=$$FMTE^XLFDT(Y,1)
- SET $PIECE(DGCL,"-",81)=""
- +1 SET X1=DGT
- SET X2=-32
- DO C^%DTC
- SET DGSTART=X
- +2 SET Y=DGT\1
- XECUTE ^DD("DD")
- SET DGDAY=Y
- +3 SET DGFL=0
- DO EEN
- IF '$DATA(^UTILITY($JOB,"DG"))
- WRITE !!?8,"*** THERE ARE NO PATIENTS OUT ON ABSENCE FOR "_DGDAY_" ***"
- GOTO QUIT
- +4 DO WR
- GOTO QUIT
- +5 ;
- EEN SET DGA="^25^26^43^44^45^13^1^2^3^"
- DO NOW^%DTC
- SET DGNOW=%
- +1 SET DGDAT=DGT
- +2 FOR DGDT=DGSTART:0
- SET DGDT=$ORDER(^DGPM("AMV2",DGDT))
- if 'DGDT!(DGDT>DGDAT)
- QUIT
- FOR DFN=0:0
- SET DFN=$ORDER(^DGPM("AMV2",DGDT,DFN))
- if 'DFN
- QUIT
- FOR DGIFN=0:0
- SET DGIFN=$ORDER(^DGPM("AMV2",DGDT,DFN,DGIFN))
- if 'DGIFN
- QUIT
- DO CK
- +3 QUIT
- CK ;check to see if xfr to absence
- +1 if '$DATA(^DGPM(+DGIFN,0))
- QUIT
- SET DGX=^(0)
- SET DGCA=$PIECE(DGX,"^",14)
- +2 if '$DATA(^DGPM(+DGCA,0))
- QUIT
- +3 ;not mvt to absence
- IF DGA'[("^"_$PIECE(DGX,"^",18)_"^")
- QUIT
- +4 ;DGFL=1 if patient returned from absence
- SET DGFL=0
- +5 SET DGFL=0
- FOR DGI=DGDT+.0000005:0
- SET DGI=$ORDER(^DGPM("APCA",DFN,DGCA,DGI))
- if 'DGI!(DGI>DGDAT)
- QUIT
- SET DGJ=$ORDER(^DGPM("APCA",DFN,DGCA,+DGI,0))
- IF $DATA(^DGPM(+DGJ,0))
- SET DGY=^(0)
- DO OUT
- +6 IF 'DGFL
- DO SET
- +7 QUIT
- SET SET VAIP("D")=DGDAT
- DO IN5^VADPT
- if VAIP(1)']""
- SET DGFL=1
- if VAIP(1)']""
- QUIT
- SET DGADM=VAIP(1)
- IF $DATA(^DGPM(DGADM,0))
- SET $PIECE(DGX,"^",5)=$PIECE(^DGPM(DGADM,0),"^",5)
- SET $PIECE(DGX,"^",6)=$PIECE(^DGPM(DGADM,0),"^",6)
- SET $PIECE(DGX,"^",13)=$PIECE(^DGPM(DGADM,0),"^",13)
- +1 if $PIECE(^DGPM(DGADM,0),"^",6)']""
- QUIT
- SET DGDV=$PIECE(^DIC(42,+$PIECE(^DGPM(DGADM,0),"^",6),0),"^",11)
- SET DGDV=$SELECT(DGDV]"":$PIECE(^DG(40.8,DGDV,0),"^"),1:"ZUNKNOWN")
- SET DGP=$PIECE(^DPT(DFN,0),"^",1)
- +2 DO PID^VADPT6
- +3 SET DGTYP=$PIECE(DGX,"^",18)
- SET DGTP=$SELECT(DGTYP=1:"PASS",DGTYP=2!(DGTYP=26):"AA",DGTYP=3!(DGTYP=25):"UA",DGTYP=13!(DGTYP=43)!(DGTYP=44)!(DGTYP=45):"ASIH",1:"")
- SET DGCD=0
- SET X=+DGX\1
- if X]""
- DO DAT
- if DGCD
- SET DGLV=DGCD
- +4 IF "^25^26^"[("^"_+VAIP(4)_"^")
- SET DGTP=$SELECT(+VAIP(4)=25:"UA",1:"AA")
- +5 SET DGCD=0
- SET X=$SELECT($PIECE(DGX,"^",13):$PIECE(DGX,"^",13),1:"")
- if X]""
- DO DAT
- SET DGRT=$SELECT(DGCD:DGCD,1:"")
- +6 SET DGW=$SELECT($PIECE(DGX,"^",5)]""&($PIECE(DGX,"^",5)'?.N):$PIECE(DGX,"^",5),$PIECE(DGX,"^",5)]""&($PIECE(DGX,"^",5)?.N):$PIECE(^DIC(4,$PIECE(DGX,"^",5),0),"^",1),1:$PIECE(^DIC(42,$PIECE(DGX,"^",6),0),"^"))
- +7 ;already returned...don't store
- IF DGFL
- QUIT
- +8 ;patient already stored once
- IF $DATA(DGDFN(DFN))
- QUIT
- +9 IF $DATA(DGASIH)
- SET DGDFN(DFN)=DFN
- SET ^UTILITY($JOB,"DG",DGDV,DGP,DFN)=VA("PID")_"^"_DGLV_"^"_DGW
- QUIT
- +10 SET DGDFN(DFN)=DFN
- SET ^UTILITY($JOB,"DG",DGDV,DGP,DFN)=VA("PID")_"^"_DGTP_"^"_DGLV_"^"_DGRT_"^"_DGW
- SET (VA("PID"),DGTP,DGLV,DGRT,DGW)=""
- +11 QUIT
- +12 ;
- OUT ;check to see if patient returned from absence - DGFL=1 if yes
- +1 SET DGTYP=$PIECE(DGY,"^",18)
- +2 IF $PIECE(DGY,"^",2)=3
- IF (DGTYP'=42)
- IF +DGY<DGDAT
- SET DGFL=1
- QUIT
- +3 IF $PIECE(DGY,"^",2)=3
- IF (DGTYP'=41)
- IF +DGY<DGDAT
- SET DGFL=1
- QUIT
- +4 IF "^14^22^23^24^"[("^"_DGTYP_"^")
- IF +DGY<DGDAT
- SET DGFL=1
- QUIT
- +5 ;future movement...ignore
- IF DGNOW<+DGY
- QUIT
- +6 ;if WHILE ASIH and not future...
- IF DGTYP=42
- IF +DGY<DGDAT
- SET DGFL=1
- QUIT
- +7 QUIT
- DAT SET DGCD=$EXTRACT(X,4,5)_"-"_$EXTRACT(X,6,7)_"-"_(1700+$EXTRACT(X,1,3))
- QUIT
- HEAD SET DGPG=DGPG+1
- WRITE @IOF,!,"ABSENCE LIST FOR ",DGDAY,?40,"PRINTED: ",DGTIME,?72," PAGE: "_DGPG
- +1 WRITE !!,"NAME",?22,"PT ID",?36,"TYPE",?42,"LEAVE",?54,"RETURN",?66,"WARD"
- +2 WRITE !,DGCL,!!,?10,"DIVISION: ",$SELECT(DGDV="ZUNKNOWN":"UNKNOWN",1:DGDV),!
- +3 QUIT
- WR SET (DGU,DGDV,DGFL,DGP)=0
- +1 FOR DGD=0:0
- SET DGDV=$ORDER(^UTILITY($JOB,"DG",DGDV))
- if DGDV=""!(DGU)
- QUIT
- SET DGPG=0
- if DGFL
- DO RT
- if DGU
- QUIT
- DO HEAD
- FOR M=0:0
- SET DGP=$ORDER(^UTILITY($JOB,"DG",DGDV,DGP))
- if DGP=""!(DGU)
- QUIT
- DO WRCNT
- +2 WRITE !
- QUIT
- WRCNT FOR DFN=0:0
- SET DFN=$ORDER(^UTILITY($JOB,"DG",DGDV,DGP,DFN))
- if 'DFN!(DGU)
- QUIT
- SET DGNO=^UTILITY($JOB,"DG",DGDV,DGP,DFN)
- DO WR1
- SET DGFL=1
- +1 QUIT
- WR1 IF $Y+4>IOSL
- if IOST?1"C-".E
- DO RT
- if DGU
- QUIT
- DO HEAD
- +1 WRITE !,$EXTRACT(DGP,1,20),?22,$PIECE(DGNO,"^"),?36,$PIECE(DGNO,"^",2),?42,$PIECE(DGNO,"^",3),?54,$PIECE(DGNO,"^",4),?66,$EXTRACT($PIECE(DGNO,"^",5),1,14)
- QUIT
- RT if IOST'?1"C-".E
- QUIT
- +1 FOR X=$Y:1:(IOSL-2)
- WRITE !
- +2 READ !?22,"Enter <RET> to continue or ^ to Quit",X:DTIME
- if X["^"!('$TEST)
- SET DGU=1
- if DGU=1
- QUIT