- FHPATM ; HISC/REL/JH - Patient Movements ;4/2/98 14:53
- ;;5.5;DIETETICS;**21**;Jan 28, 2005;Build 6
- ;Integration Agreements added FH*5.5*21 SLC/GDU
- ;GLOBAL REFERENCE FIELD REFERECE DBIA
- ;^DG(405.4,D0 .01 NAME 0;1 1380
- ;^DGPM(APTT1,DFN, 2090
- ;^DGPM(APTT2,DFN, 2090
- ;^DGPM(APTT4,DFN, 2090
- ;^DGPM(APID,DFN,INVERSE DATE_AS,DA 2090
- ;^DGPM(DO,0 .03 PATIENT 0;3 2090
- ; .06 WARD LOCATION 0;6 2090
- ; .07 ROOM-BED 0;7 2090
- ; .14 ADMISSION/CHECK-IN MOVEMENT 0;14 2090
- ; .18 MAS MOVEMENT 0;18 2090
- ;^DIC(42,DO,0) .015 DIVISION 0;11 10039
- S DAT=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
- S X1=DT,X2=-5 D C^%DTC I DAT<X W " [ DATE MORE THAN 5 DAYS IN PAST ]" G P1
- D DIVISION^VAUTOMA
- P2 W ! K IOP S %ZIS="MQ",%ZIS("A")="Select LIST Printer: " D ^%ZIS K %ZIS,IOP G:POP KIL
- I $D(IO("Q")) S FHPGM="F0^FHPATM",FHLST="DAT^DT^VAUTD*" D EN2^FH G KIL
- U IO D F0,NOTE D ^%ZISC K %ZIS,IOP G KIL
- F0 D HDR W !!?5,"Name",?24,"ID#",?35,"Date/Time",?49,"FROM Ward-Bed",?65,"TO Ward-Bed"
- W !!?26,"--- A D M I S S I O N S ---",! S NOD="ATT1" D FND
- W !!?26,"--- D I S C H A R G E S ---",! S NOD="ATT3" D FND
- W !!?27,"--- T R A N S F E R S ---",! S NOD="ATT2" D FND W ! Q
- HDR S H1="" I DAT S DTP=DAT D DTP^FH S H1=DTP_" to "
- W:$E(IOST,1,2)="C-" @IOF W !?23,"P A T I E N T M O V E M E N T S"
- I $D(VAUTD) D
- . W !,"Division: " I $D(VAUTD)=1 W "ALL" Q
- . N N F N=0:0 S N=$O(VAUTD(N)) Q:'N W VAUTD(N) W:$O(VAUTD(N))>0 ", "
- D NOW^%DTC S (DTP,NOW)=%,DT=NOW\1 D DTP^FH S H1=H1_DTP W !!?(80-$L(H1)\2),H1 Q
- FND S NX=DAT-.0000005
- F1 S NX=$O(^DGPM(NOD,NX)) Q:NX<1!(NX'<NOW)
- F DA=0:0 S DA=$O(^DGPM(NOD,NX,DA)) Q:DA="" S X1=$G(^DGPM(DA,0)),NOWRD=0 D PRT
- G F1
- PRT S DFN=+$P(X1,"^",3),ADM=$P(X1,"^",14),XT=$P(X1,"^",18) Q:ADM<1 D P0
- Q
- P0 Q:'$D(^DPT(DFN,0)) S Y(0)=^(0) D PID^FHDPA I NOD="ATT1",XT=40 Q
- I NOD="ATT3",XT=41!(XT=42)!(XT=46)!(XT=47) Q
- S FH7R=0 D GET Q:NOD="ATT1"&TW="" S:'FH7R FH7R=0 Q:'$G(VAUTD)&'$D(VAUTD(FH7R))
- W !,$E($P(Y(0),"^",1),1,21),?23,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")
- W ?48,FW,?65,TW W:NOWRD="*" ?79,NOWRD Q
- GET S (FW,FR)="" I NOD="ATT3" S (TW,TR)="" D LST G G1
- S TW=$P(X1,"^",6),TR=$P(X1,"^",7) I NOD="ATT1" Q:'TW S NOWRD=$O(^FH(119.6,"AW",TW,0)) S:'NOWRD NOWRD="*" G G1
- S FW=TW,FR=TR
- I "^1^2^3^25^26^43^45^"[("^"_XT_"^") S TW=$S(XT=2!(XT=26):"AUTH LEAVE",XT=3!(XT=25):"UA LEAVE",XT=1:"ON PASS",XT=43!(XT=45):"ASIH OTHER",1:TW),TR=""
- I "^22^23^24^25^26^44^"[("^"_XT_"^") S FW=$S(XT=24!(XT=25):"AUTH LEAVE",XT=22!(XT=26):"UA LEAVE",XT=23:"PASS",XT=44:"ASIH OTHER",1:FW),FR=""
- I "^4^13^14^45^"[("^"_XT_"^") D LST
- G1 S:FW FH7R=$P($G(^DIC(42,FW,0)),"^",11) I 'FH7R,TW S FH7R=$P($G(^DIC(42,TW,0)),"^",11)
- S:FW FW=$O(^FH(119.6,"AW",FW,0)) S:FW FW=$P($G(^FH(119.6,FW,0)),U) S SW=TW S:TW TW=$O(^FH(119.6,"AW",TW,0))
- I TW S TW=$P($G(^FH(119.6,TW,0)),U)
- E S:SW TW=$P(^DIC(42,SW,0),U),NOWRD="*"
- S:FR FR=$P(^DG(405.4,FR,0),"^",1) S:TR TR=$P(^DG(405.4,TR,0),"^",1)
- S FW=FW_" "_FR,TW=TW_" "_TR Q ;S FW=$E(FW,1,14-$L(FR))_" "_FR,TW=$E(TW,1,14-$L(TR))_" "_TR Q
- LST S TRN=9999999.9999999-$E(NX,1,14)
- F TRN=TRN:0 S TRN=$O(^DGPM("APID",DFN,TRN)) Q:TRN="" F T0=0:0 S T0=$O(^DGPM("APID",DFN,TRN,T0)) Q:T0="" I T0'=DA S X=$G(^DGPM(T0,0)),FW=$P(X,"^",6),FR=$P(X,"^",7) G:FW L1
- L1 S:"^43^45^"[("^"_$P(X,"^",18)_"^") FR="",FW="ASIH OTHER" Q
- NOTE W !!,"* Denotes that there is no associated Ward in the Dietetic Ward File!" Q
- KIL G KILL^XUSCLEAN
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHPATM 4051 printed Feb 18, 2025@23:20:32 Page 2
- FHPATM ; HISC/REL/JH - Patient Movements ;4/2/98 14:53
- +1 ;;5.5;DIETETICS;**21**;Jan 28, 2005;Build 6
- +2 ;Integration Agreements added FH*5.5*21 SLC/GDU
- +3 ;GLOBAL REFERENCE FIELD REFERECE DBIA
- +4 ;^DG(405.4,D0 .01 NAME 0;1 1380
- +5 ;^DGPM(APTT1,DFN, 2090
- +6 ;^DGPM(APTT2,DFN, 2090
- +7 ;^DGPM(APTT4,DFN, 2090
- +8 ;^DGPM(APID,DFN,INVERSE DATE_AS,DA 2090
- +9 ;^DGPM(DO,0 .03 PATIENT 0;3 2090
- +10 ; .06 WARD LOCATION 0;6 2090
- +11 ; .07 ROOM-BED 0;7 2090
- +12 ; .14 ADMISSION/CHECK-IN MOVEMENT 0;14 2090
- +13 ; .18 MAS MOVEMENT 0;18 2090
- +14 ;^DIC(42,DO,0) .015 DIVISION 0;11 10039
- +15 SET DAT=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 SET X1=DT
- SET X2=-5
- DO C^%DTC
- IF DAT<X
- WRITE " [ DATE MORE THAN 5 DAYS IN PAST ]"
- GOTO P1
- +3 DO DIVISION^VAUTOMA
- P2 WRITE !
- KILL IOP
- SET %ZIS="MQ"
- SET %ZIS("A")="Select LIST Printer: "
- DO ^%ZIS
- KILL %ZIS,IOP
- if POP
- GOTO KIL
- +1 IF $DATA(IO("Q"))
- SET FHPGM="F0^FHPATM"
- SET FHLST="DAT^DT^VAUTD*"
- DO EN2^FH
- GOTO KIL
- +2 USE IO
- DO F0
- DO NOTE
- DO ^%ZISC
- KILL %ZIS,IOP
- GOTO KIL
- F0 DO HDR
- WRITE !!?5,"Name",?24,"ID#",?35,"Date/Time",?49,"FROM Ward-Bed",?65,"TO Ward-Bed"
- +1 WRITE !!?26,"--- A D M I S S I O N S ---",!
- SET NOD="ATT1"
- DO FND
- +2 WRITE !!?26,"--- D I S C H A R G E S ---",!
- SET NOD="ATT3"
- DO FND
- +3 WRITE !!?27,"--- T R A N S F E R S ---",!
- SET NOD="ATT2"
- DO FND
- WRITE !
- QUIT
- HDR SET H1=""
- IF DAT
- SET DTP=DAT
- DO DTP^FH
- SET H1=DTP_" to "
- +1 if $EXTRACT(IOST,1,2)="C-"
- WRITE @IOF
- WRITE !?23,"P A T I E N T M O V E M E N T S"
- +2 IF $DATA(VAUTD)
- Begin DoDot:1
- +3 WRITE !,"Division: "
- IF $DATA(VAUTD)=1
- WRITE "ALL"
- QUIT
- +4 NEW N
- FOR N=0:0
- SET N=$ORDER(VAUTD(N))
- if 'N
- QUIT
- WRITE VAUTD(N)
- if $ORDER(VAUTD(N))>0
- WRITE ", "
- End DoDot:1
- +5 DO NOW^%DTC
- SET (DTP,NOW)=%
- SET DT=NOW\1
- DO DTP^FH
- SET H1=H1_DTP
- WRITE !!?(80-$LENGTH(H1)\2),H1
- QUIT
- FND SET NX=DAT-.0000005
- F1 SET NX=$ORDER(^DGPM(NOD,NX))
- if NX<1!(NX'<NOW)
- QUIT
- +1 FOR DA=0:0
- SET DA=$ORDER(^DGPM(NOD,NX,DA))
- if DA=""
- QUIT
- SET X1=$GET(^DGPM(DA,0))
- SET NOWRD=0
- DO PRT
- +2 GOTO F1
- PRT SET DFN=+$PIECE(X1,"^",3)
- SET ADM=$PIECE(X1,"^",14)
- SET XT=$PIECE(X1,"^",18)
- if ADM<1
- QUIT
- DO P0
- +1 QUIT
- P0 if '$DATA(^DPT(DFN,0))
- QUIT
- SET Y(0)=^(0)
- DO PID^FHDPA
- IF NOD="ATT1"
- IF XT=40
- QUIT
- +1 IF NOD="ATT3"
- IF XT=41!(XT=42)!(XT=46)!(XT=47)
- QUIT
- +2 SET FH7R=0
- DO GET
- if NOD="ATT1"&TW=""
- QUIT
- if 'FH7R
- SET FH7R=0
- if '$GET(VAUTD)&'$DATA(VAUTD(FH7R))
- QUIT
- +3 WRITE !,$EXTRACT($PIECE(Y(0),"^",1),1,21),?23,BID
- +4 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))
- +5 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")
- +6 WRITE ?48,FW,?65,TW
- if NOWRD="*"
- WRITE ?79,NOWRD
- QUIT
- GET SET (FW,FR)=""
- IF NOD="ATT3"
- SET (TW,TR)=""
- DO LST
- GOTO G1
- +1 SET TW=$PIECE(X1,"^",6)
- SET TR=$PIECE(X1,"^",7)
- IF NOD="ATT1"
- if 'TW
- QUIT
- SET NOWRD=$ORDER(^FH(119.6,"AW",TW,0))
- if 'NOWRD
- SET NOWRD="*"
- GOTO G1
- +2 SET FW=TW
- SET FR=TR
- +3 IF "^1^2^3^25^26^43^45^"[("^"_XT_"^")
- SET TW=$SELECT(XT=2!(XT=26):"AUTH LEAVE",XT=3!(XT=25):"UA LEAVE",XT=1:"ON PASS",XT=43!(XT=45):"ASIH OTHER",1:TW)
- SET TR=""
- +4 IF "^22^23^24^25^26^44^"[("^"_XT_"^")
- SET FW=$SELECT(XT=24!(XT=25):"AUTH LEAVE",XT=22!(XT=26):"UA LEAVE",XT=23:"PASS",XT=44:"ASIH OTHER",1:FW)
- SET FR=""
- +5 IF "^4^13^14^45^"[("^"_XT_"^")
- DO LST
- G1 if FW
- SET FH7R=$PIECE($GET(^DIC(42,FW,0)),"^",11)
- IF 'FH7R
- IF TW
- SET FH7R=$PIECE($GET(^DIC(42,TW,0)),"^",11)
- +1 if FW
- SET FW=$ORDER(^FH(119.6,"AW",FW,0))
- if FW
- SET FW=$PIECE($GET(^FH(119.6,FW,0)),U)
- SET SW=TW
- if TW
- SET TW=$ORDER(^FH(119.6,"AW",TW,0))
- +2 IF TW
- SET TW=$PIECE($GET(^FH(119.6,TW,0)),U)
- +3 IF '$TEST
- if SW
- SET TW=$PIECE(^DIC(42,SW,0),U)
- SET NOWRD="*"
- +4 if FR
- SET FR=$PIECE(^DG(405.4,FR,0),"^",1)
- if TR
- SET TR=$PIECE(^DG(405.4,TR,0),"^",1)
- +5 ;S FW=$E(FW,1,14-$L(FR))_" "_FR,TW=$E(TW,1,14-$L(TR))_" "_TR Q
- SET FW=FW_" "_FR
- SET TW=TW_" "_TR
- QUIT
- LST SET TRN=9999999.9999999-$EXTRACT(NX,1,14)
- +1 FOR TRN=TRN:0
- SET TRN=$ORDER(^DGPM("APID",DFN,TRN))
- if TRN=""
- QUIT
- FOR T0=0:0
- SET T0=$ORDER(^DGPM("APID",DFN,TRN,T0))
- if T0=""
- QUIT
- IF T0'=DA
- SET X=$GET(^DGPM(T0,0))
- SET FW=$PIECE(X,"^",6)
- SET FR=$PIECE(X,"^",7)
- if FW
- GOTO L1
- L1 if "^43^45^"[("^"_$PIECE(X,"^",18)_"^")
- SET FR=""
- SET FW="ASIH OTHER"
- QUIT
- NOTE WRITE !!,"* Denotes that there is no associated Ward in the Dietetic Ward File!"
- QUIT
- KIL GOTO KILL^XUSCLEAN