- DGOPATM ;GLRISC/REL - Patient Movements ; [ 09/13/2001 3:55 PM ]
- ;;5.3;Registration;**93,162,1015**;Aug 13, 1993;Build 21
- ;IHS/ANMC/LJF 5/24/2001 changed date limit to 14 days into past
- ; added choice of type of movement
- ;
- S (DAT,DGU)=0 D HDR
- P1 S %DT="AEXT",%DT("A")="START with DATE@TIME: " W ! D ^%DT G:Y<1 KIL S DAT=Y
- I DAT>NOW W " [ Date cannot be in Future ]" G P1
- ;
- ;
- ;IHS/ANMC/LJF 5/24/2001 IHS changes
- ;S X1=DT,X2=-5 D C^%DTC I DAT<X W " [ DATE MORE THAN 5 DAYS IN PAST ]" G P1
- S X1=DT,X2=-14 D C^%DTC I DAT<X W " [ DATE MORE THAN 14 DAYS IN PAST ]" G P1
- ;
- NEW BDGADT S BDGADT=$$READ^BDGF("S^A:Admissions;D:Discharges;T:Transfers;ALL:All Movements","Choose Movements to Display","ALL") Q:BDGADT=U
- I BDGADT="ALL" S BDGADT="ADT"
- ;
- P2 ;S DGVAR="DAT^DGU",DGPGM="F0^DGOPATM" W ! D ZIS^DGUTQ I 'POP U IO G F0^DGOPATM
- S DGVAR="DAT^DGU^BDGADT",DGPGM="F0^DGOPATM" W ! D ZIS^DGUTQ I 'POP U IO G F0^DGOPATM
- ;IHS/ANMC/LJF 5/24/2001 end of changes
- ;
- ;
- KIL K %,%DT,%ZIS,ADM,DAT,DFN,DTP,DGVAR,DGPGM,DGU,DGX,FHA1,FW,FR,H1,I2,KK,LL,LST,NOD,NOW,NX,POP,RM,T1,TRN,TW,TR,X,X1,X2,Y,VA("BID"),VA("PID"),VAIP,VAERR,VADAT,VADATE D CLOSE^DGUTQ Q
- F0 D HDR1
- ;
- ;
- ;IHS/ANMC/LJF 5/24/2001 more IHS changes
- ;S DGX="--- A D M I S S I O N S ---" W !!?26,DGX,! S NOD="AMV1" D FND G KIL:DGU
- ;S DGX="--- D I S C H A R G E S ---" W !!?26,DGX,! S NOD="AMV3" D FND G KIL:DGU
- ;S DGX="--- T R A N S F E R S ---" W !!?26,DGX,! S NOD="AMV2" D FND W ! G KIL:DGU
- I BDGADT["A" S DGX="--- A D M I S S I O N S ---" W !!?26,DGX,! S NOD="AMV1" D FND G KIL:DGU
- I BDGADT["D" S DGX="--- D I S C H A R G E S ---" W !!?26,DGX,! S NOD="AMV3" D FND G KIL:DGU
- I BDGADT["T" S DGX="--- T R A N S F E R S ---" W !!?26,DGX,! S NOD="AMV2" D FND W ! G KIL:DGU
- D PAUSE^BDGF
- ;IHS/ANMC/LJF 5/24/2001 end of changes
- ;
- ;
- G KIL
- DTP S DTP=$E(DTP,1,12) S DTP=$$FMTE^XLFDT(DTP,"1P") Q
- HDR S H1="" I DAT S DTP=DAT D DTP S H1=DTP_" to "
- W @IOF,!!?23,"P A T I E N T M O V E M E N T S"
- D NOW^%DTC S (DTP,NOW)=%,DT=NOW\1 D DTP S H1=H1_DTP W !!?(80-$L(H1)\2),H1 Q
- FND S NX=$P(DAT,".",1)-.0001
- FN1 S NX=$O(^DGPM(NOD,NX)) I NX=""!(NX[".")!(NX>(DAT\1)) G FN2
- F DFN=0:0 S DFN=$O(^DGPM(NOD,NX,DFN)) Q:'DFN D PRT Q:DGU
- FN2 S LST=DT+1,NX=DAT+$S(DAT[".":-.0001,1:.0000001)
- FN3 S NX=$O(^DGPM(NOD,NX)) Q:NX=""!(NX'<LST)!(DGU)
- F DFN=0:0 S DFN=$O(^DGPM(NOD,NX,DFN)) G:'DFN FN3 D PRT Q:DGU
- Q:DGU
- PRT S ADM=$O(^DGPM(NOD,NX,DFN,0)) Q:'ADM D P0
- Q
- P0 Q:'$D(^DPT(DFN,0)) S Y(0)=^(0) Q:'$D(^DGPM(ADM,0))
- I NOD="AMV1" S X1=$P(^DGPM(ADM,0),"^",18) Q:X1=40
- I NOD="AMV3" S X1=$P(^DGPM(ADM,0),"^",18) I X1=41!(X1=42)!(X1=46)!(X1=47) Q
- I $Y+6>IOSL D RT Q:DGU
- D PID^VADPT6 W !,$E($P(Y(0),"^",1),1,22),?24,VA("BID")
- W ?32,$J(+$E(NX,6,7),2),"-",$P("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec"," ",+$E(NX,4,5))
- I NX#1 S I2=+$E(NX_"0",9,10) W $J($S(I2>12:I2-12,1:I2),3),":",$E(NX_"000",11,12),$S(I2>11:"pm",1:"am")
- D GET W ?48,FW,?65,TW Q
- GET S (FW,TW,FR,TR)=""
- S X1=^DGPM(ADM,0) I NOD="AMV1" S TW=$P(X1,"^",6),TR=$P(X1,"^",7) G G1
- S FW=$P(X1,"^",6),FR=$P(X1,"^",7) G:NOD="AMV2" G0
- S VAIP("E")=ADM D IN5^VADPT I VAIP(15)]"" S T1=^DGPM(VAIP(15),0) S:T1<NX FW=$P(T1,"^",6) S:$P(T1,"^",7) FR=$P(T1,"^",7) I +T1'<NX S TW=$P(T1,"^",6) S:$P(T1,"^",7) TR=$P(T1,"^",7)
- S:TW'="" FW=TW,TW="",FR=TR,TR="" G G1
- G0 S X2="",VAIP("E")=ADM D IN5^VADPT
- I VAIP(15)]"" S X1=^DGPM(VAIP(15),0) I X1<NX S FW=$P(X1,"^",6),FR=$P(X1,"^",7),X2=$P(X1,"^",18)
- S X1=^DGPM(ADM,0),TW=$P(X1,"^",6),TR=$P(X1,"^",7)
- S X1=$P(X1,"^",18)
- I "^1^2^3^25^43^45^"[("^"_X1_"^") S TW=$S(X1=2:"AUTH LEAVE",X1=3!(X1=25):"UA LEAVE",X1=1:"ON PASS",X1=44:"ASIH",X1=43!(X1=45):"ASIH OTHER",1:TW),TR=""
- I "^14^22^23^24^44^45^"[("^"_X1_"^") S FW=$S(X1=24:"AUTH LEAVE",X1=22:"UA LEAVE",X1=23:"FROM PASS",X2=43!(X1=45)!(X1=44):"ASIH OTHER",1:FW) I X1'=14,(X2'=13) S FR="" ; keep room if returning from asih in same hosp
- G1 S:FW FW=$P(^DIC(42,FW,0),"^",1) S:TW TW=$P(^DIC(42,TW,0),"^",1)
- S:FR FR=$P(^DG(405.4,FR,0),"^",1) S:TR TR=$P(^DG(405.4,TR,0),"^",1)
- S FW=$E(FW,1,14-$L(FR))_" "_FR,TW=$E(TW,1,14-$L(TR))_" "_TR Q
- RT F X=$Y:1:(IOSL-2) W !
- I (IOST?1"C-".E) R ?22,"Enter <RET> to continue or '^' to QUIT ",X:DTIME S:X["^"!('$T) DGU=1 Q:DGU
- D HDR1 W !!?26,DGX,! Q
- HDR1 D HDR W !!?5,"Name",?24,"PT ID",?35,"Date/Time",?49,"FROM Ward-Bed",?67,"TO Ward-Bed"
- DGOPATM ;GLRISC/REL - Patient Movements ; [ 09/13/2001 3:55 PM ]
- +1 ;;5.3;Registration;**93,162,1015**;Aug 13, 1993;Build 21
- +2 ;IHS/ANMC/LJF 5/24/2001 changed date limit to 14 days into past
- +3 ; added choice of type of movement
- +4 ;
- +5 SET (DAT,DGU)=0
- DO HDR
- P1 SET %DT="AEXT"
- SET %DT("A")="START with DATE@TIME: "
- WRITE !
- DO ^%DT
- IF Y<1
- GOTO KIL
- SET DAT=Y
- +1 IF DAT>NOW
- WRITE " [ Date cannot be in Future ]"
- GOTO P1
- +2 ;
- +3 ;
- +4 ;IHS/ANMC/LJF 5/24/2001 IHS changes
- +5 ;S X1=DT,X2=-5 D C^%DTC I DAT<X W " [ DATE MORE THAN 5 DAYS IN PAST ]" G P1
- +6 SET X1=DT
- SET X2=-14
- DO C^%DTC
- IF DAT<X
- WRITE " [ DATE MORE THAN 14 DAYS IN PAST ]"
- GOTO P1
- +7 ;
- +8 NEW BDGADT
- SET BDGADT=$$READ^BDGF("S^A:Admissions;D:Discharges;T:Transfers;ALL:All Movements","Choose Movements to Display","ALL")
- IF BDGADT=U
- QUIT
- +9 IF BDGADT="ALL"
- SET BDGADT="ADT"
- +10 ;
- P2 ;S DGVAR="DAT^DGU",DGPGM="F0^DGOPATM" W ! D ZIS^DGUTQ I 'POP U IO G F0^DGOPATM
- +1 SET DGVAR="DAT^DGU^BDGADT"
- SET DGPGM="F0^DGOPATM"
- WRITE !
- DO ZIS^DGUTQ
- IF 'POP
- USE IO
- GOTO F0^DGOPATM
- +2 ;IHS/ANMC/LJF 5/24/2001 end of changes
- +3 ;
- +4 ;
- KIL KILL %,%DT,%ZIS,ADM,DAT,DFN,DTP,DGVAR,DGPGM,DGU,DGX,FHA1,FW,FR,H1,I2,KK,LL,LST,NOD,NOW,NX,POP,RM,T1,TRN,TW,TR,X,X1,X2,Y,VA("BID"),VA("PID"),VAIP,VAERR,VADAT,VADATE
- DO CLOSE^DGUTQ
- QUIT
- F0 DO HDR1
- +1 ;
- +2 ;
- +3 ;IHS/ANMC/LJF 5/24/2001 more IHS changes
- +4 ;S DGX="--- A D M I S S I O N S ---" W !!?26,DGX,! S NOD="AMV1" D FND G KIL:DGU
- +5 ;S DGX="--- D I S C H A R G E S ---" W !!?26,DGX,! S NOD="AMV3" D FND G KIL:DGU
- +6 ;S DGX="--- T R A N S F E R S ---" W !!?26,DGX,! S NOD="AMV2" D FND W ! G KIL:DGU
- +7 IF BDGADT["A"
- SET DGX="--- A D M I S S I O N S ---"
- WRITE !!?26,DGX,!
- SET NOD="AMV1"
- DO FND
- IF DGU
- GOTO KIL
- +8 IF BDGADT["D"
- SET DGX="--- D I S C H A R G E S ---"
- WRITE !!?26,DGX,!
- SET NOD="AMV3"
- DO FND
- IF DGU
- GOTO KIL
- +9 IF BDGADT["T"
- SET DGX="--- T R A N S F E R S ---"
- WRITE !!?26,DGX,!
- SET NOD="AMV2"
- DO FND
- WRITE !
- IF DGU
- GOTO KIL
- +10 DO PAUSE^BDGF
- +11 ;IHS/ANMC/LJF 5/24/2001 end of changes
- +12 ;
- +13 ;
- +14 GOTO KIL
- DTP SET DTP=$EXTRACT(DTP,1,12)
- SET DTP=$$FMTE^XLFDT(DTP,"1P")
- QUIT
- HDR SET H1=""
- IF DAT
- SET DTP=DAT
- DO DTP
- SET H1=DTP_" to "
- +1 WRITE @IOF,!!?23,"P A T I E N T M O V E M E N T S"
- +2 DO NOW^%DTC
- SET (DTP,NOW)=%
- SET DT=NOW\1
- DO DTP
- SET H1=H1_DTP
- WRITE !!?(80-$LENGTH(H1)\2),H1
- QUIT
- FND SET NX=$PIECE(DAT,".",1)-.0001
- FN1 SET NX=$ORDER(^DGPM(NOD,NX))
- IF NX=""!(NX[".")!(NX>(DAT\1))
- GOTO FN2
- +1 FOR DFN=0:0
- SET DFN=$ORDER(^DGPM(NOD,NX,DFN))
- IF 'DFN
- QUIT
- DO PRT
- IF DGU
- QUIT
- FN2 SET LST=DT+1
- SET NX=DAT+$SELECT(DAT[".":-.0001,1:.0000001)
- FN3 SET NX=$ORDER(^DGPM(NOD,NX))
- IF NX=""!(NX'<LST)!(DGU)
- QUIT
- +1 FOR DFN=0:0
- SET DFN=$ORDER(^DGPM(NOD,NX,DFN))
- IF 'DFN
- GOTO FN3
- DO PRT
- IF DGU
- QUIT
- +2 IF DGU
- QUIT
- PRT SET ADM=$ORDER(^DGPM(NOD,NX,DFN,0))
- IF 'ADM
- QUIT
- DO P0
- +1 QUIT
- P0 IF '$DATA(^DPT(DFN,0))
- QUIT
- SET Y(0)=^(0)
- IF '$DATA(^DGPM(ADM,0))
- QUIT
- +1 IF NOD="AMV1"
- SET X1=$PIECE(^DGPM(ADM,0),"^",18)
- IF X1=40
- QUIT
- +2 IF NOD="AMV3"
- SET X1=$PIECE(^DGPM(ADM,0),"^",18)
- IF X1=41!(X1=42)!(X1=46)!(X1=47)
- QUIT
- +3 IF $Y+6>IOSL
- DO RT
- IF DGU
- QUIT
- +4 DO PID^VADPT6
- WRITE !,$EXTRACT($PIECE(Y(0),"^",1),1,22),?24,VA("BID")
- +5 WRITE ?32,$JUSTIFY(+$EXTRACT(NX,6,7),2),"-",$PIECE("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec"," ",+$EXTRACT(NX,4,5))
- +6 IF NX#1
- SET I2=+$EXTRACT(NX_"0",9,10)
- WRITE $JUSTIFY($SELECT(I2>12:I2-12,1:I2),3),":",$EXTRACT(NX_"000",11,12),$SELECT(I2>11:"pm",1:"am")
- +7 DO GET
- WRITE ?48,FW,?65,TW
- QUIT
- GET SET (FW,TW,FR,TR)=""
- +1 SET X1=^DGPM(ADM,0)
- IF NOD="AMV1"
- SET TW=$PIECE(X1,"^",6)
- SET TR=$PIECE(X1,"^",7)
- GOTO G1
- +2 SET FW=$PIECE(X1,"^",6)
- SET FR=$PIECE(X1,"^",7)
- IF NOD="AMV2"
- GOTO G0
- +3 SET VAIP("E")=ADM
- DO IN5^VADPT
- IF VAIP(15)]""
- SET T1=^DGPM(VAIP(15),0)
- IF T1<NX
- SET FW=$PIECE(T1,"^",6)
- IF $PIECE(T1,"^",7)
- SET FR=$PIECE(T1,"^",7)
- IF +T1'<NX
- SET TW=$PIECE(T1,"^",6)
- IF $PIECE(T1,"^",7)
- SET TR=$PIECE(T1,"^",7)
- +4 IF TW'=""
- SET FW=TW
- SET TW=""
- SET FR=TR
- SET TR=""
- GOTO G1
- G0 SET X2=""
- SET VAIP("E")=ADM
- DO IN5^VADPT
- +1 IF VAIP(15)]""
- SET X1=^DGPM(VAIP(15),0)
- IF X1<NX
- SET FW=$PIECE(X1,"^",6)
- SET FR=$PIECE(X1,"^",7)
- SET X2=$PIECE(X1,"^",18)
- +2 SET X1=^DGPM(ADM,0)
- SET TW=$PIECE(X1,"^",6)
- SET TR=$PIECE(X1,"^",7)
- +3 SET X1=$PIECE(X1,"^",18)
- +4 IF "^1^2^3^25^43^45^"[("^"_X1_"^")
- SET TW=$SELECT(X1=2:"AUTH LEAVE",X1=3!(X1=25):"UA LEAVE",X1=1:"ON PASS",X1=44:"ASIH",X1=43!(X1=45):"ASIH OTHER",1:TW)
- SET TR=""
- +5 ; keep room if returning from asih in same hosp
- IF "^14^22^23^24^44^45^"[("^"_X1_"^")
- SET FW=$SELECT(X1=24:"AUTH LEAVE",X1=22:"UA LEAVE",X1=23:"FROM PASS",X2=43!(X1=45)!(X1=44):"ASIH OTHER",1:FW)
- IF X1'=14
- IF (X2'=13)
- SET FR=""
- G1 IF FW
- SET FW=$PIECE(^DIC(42,FW,0),"^",1)
- IF TW
- SET TW=$PIECE(^DIC(42,TW,0),"^",1)
- +1 IF FR
- SET FR=$PIECE(^DG(405.4,FR,0),"^",1)
- IF TR
- SET TR=$PIECE(^DG(405.4,TR,0),"^",1)
- +2 SET FW=$EXTRACT(FW,1,14-$LENGTH(FR))_" "_FR
- SET TW=$EXTRACT(TW,1,14-$LENGTH(TR))_" "_TR
- QUIT
- RT FOR X=$Y:1:(IOSL-2)
- WRITE !
- +1 IF (IOST?1"C-".E)
- READ ?22,"Enter <RET> to continue or '^' to QUIT ",X:DTIME
- IF X["^"!('$TEST)
- SET DGU=1
- IF DGU
- QUIT
- +2 DO HDR1
- WRITE !!?26,DGX,!
- QUIT
- HDR1 DO HDR
- WRITE !!?5,"Name",?24,"PT ID",?35,"Date/Time",?49,"FROM Ward-Bed",?67,"TO Ward-Bed"
