FHORD5 ; HISC/REL/NCA - Withhold Lists ;3/16/95 14:21
;;5.5;DIETETICS;;Jan 28, 2005
W @IOF,!!?27,"N P O / P A S S L I S T",!!
S FHP=$O(^FH(119.73,0)) I FHP'<1,$O(^FH(119.73,FHP))<1 S FHP=0 G R1
R0 R !!,"Select COMMUNICATION OFFICE (or ALL): ",X:DTIME G:'$T!("^"[X) KIL D:X="all" TR^FH I X="ALL" S FHP=0
E K DIC S DIC="^FH(119.73,",DIC(0)="EMQ" D ^DIC G:Y<1 R0 S FHP=+Y
R1 R !!,"Sort by WARD or DATE/TIME? WARD// ",SRT:DTIME G:'$T!(SRT["^") KIL S:SRT="" SRT="W" S X=SRT D TR^FH S SRT=X
I $P("WARD",SRT,1)'="",$P("DATE/TIME",SRT,1)'="" W *7," Enter W or D" G R1
S SRT=$E(SRT,1)
R2 W !!,"The list requires a 132 column printer.",!
W ! K IOP,%ZIS S %ZIS("A")="Select LIST Printer: ",%ZIS="MQ" D ^%ZIS K %ZIS,IOP G:POP KIL
I $D(IO("Q")) S FHPGM="F1^FHORD5",FHLST="FHP^SRT" D EN2^FH G KIL
U IO D F1 D ^%ZISC K %ZIS,IOP G KIL
KIL K ^TMP($J) G KILL^XUSCLEAN
F1 ; List Withholds
D NOW^%DTC S NOW=%,DT=NOW\1 S X1=NOW,X2=-3 D C^%DTC S OLD=+X,PG=0 D HDR K ^TMP($J)
F W1=0:0 S W1=$O(^FHPT("AW",W1)) Q:W1'>0 D DP I 'FHP!(D1=FHP) F FHDFN=0:0 S FHDFN=$O(^FHPT("AW",W1,FHDFN)) Q:FHDFN<1 S ADM=$G(^FHPT("AW",W1,FHDFN)) I ADM>0 D F2
S WRDN="" F A3=0:0 S WRDN=$O(^TMP($J,WRDN)) Q:WRDN="" F FHDFN=0:0 S FHDFN=$O(^TMP($J,WRDN,FHDFN)) Q:FHDFN<1 S X=$G(^TMP($J,WRDN,FHDFN)) D F3
W ! Q
F2 D PATNAME^FHOMUTL I DFN="" Q
S Y(0)=^DPT(DFN,0) Q:'$D(^FHPT(FHDFN,"A",ADM,0)) Q:$P(^(0),"^",4) D CUR^FHORD7 Q:FHLD=""
S A1=0 F K=0:0 S K=$O(^FHPT(FHDFN,"A",ADM,"AC",K)) Q:K<1!(K>NOW) I $P(^(K,0),"^",2)=FHORD S A1=K
S D2=$P(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),"^",10) D PID^FHDPA
S RM=$E(WRDN,1,14) I $D(^DPT(DFN,.101)) S RM=RM_"/"_^(.101)
S ^TMP($J,$S(SRT="W":WRDN,1:A1),FHDFN)=$E(RM,1,21)_"^"_$P(Y(0),"^",1)_"^"_BID_"^"_A1_"^"_D2_"^"_Y Q
F3 D:$Y>58 HDR W !,$P(X,"^",1),?24,$P(X,"^",2),?55,$P(X,"^",3)
S D1=$P(X,"^",4),D2=$P(X,"^",5)
S DTP=D1 D DTP^FH W ?64,DTP I D2 S DTP=D2 D DTP^FH W ?83,DTP
W:D1<OLD ?102,"*" W ?106,$P(X,"^",6) Q
DP S WRDN=$P(^FH(119.6,W1,0),"^",1),D1=$P(^(0),"^",8) Q
HDR W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1 W !?44,"N P O / P A S S L I S T",?107,"Page ",PG
W !! W:FHP $P(^FH(119.73,FHP,0),"^",1) S DTP=NOW D DTP^FH W ?48,DTP
W !!,"WARD/ROOM",?24,"PATIENT",?56,"ID#",?65,"EFFECTIVE DATE",?84,"EXPIRATION DATE",?102,">3",?106,"REASON",! Q
FHORD5 ; HISC/REL/NCA - Withhold Lists ;3/16/95 14:21
+1 ;;5.5;DIETETICS;;Jan 28, 2005
+2 WRITE @IOF,!!?27,"N P O / P A S S L I S T",!!
+3 SET FHP=$ORDER(^FH(119.73,0))
IF FHP'<1
IF $ORDER(^FH(119.73,FHP))<1
SET FHP=0
GOTO R1
R0 READ !!,"Select COMMUNICATION OFFICE (or ALL): ",X:DTIME
IF '$TEST!("^"[X)
GOTO KIL
IF X="all"
DO TR^FH
IF X="ALL"
SET FHP=0
+1 IF '$TEST
KILL DIC
SET DIC="^FH(119.73,"
SET DIC(0)="EMQ"
DO ^DIC
IF Y<1
GOTO R0
SET FHP=+Y
R1 READ !!,"Sort by WARD or DATE/TIME? WARD// ",SRT:DTIME
IF '$TEST!(SRT["^")
GOTO KIL
IF SRT=""
SET SRT="W"
SET X=SRT
DO TR^FH
SET SRT=X
+1 IF $PIECE("WARD",SRT,1)'=""
IF $PIECE("DATE/TIME",SRT,1)'=""
WRITE *7," Enter W or D"
GOTO R1
+2 SET SRT=$EXTRACT(SRT,1)
R2 WRITE !!,"The list requires a 132 column printer.",!
+1 WRITE !
KILL IOP,%ZIS
SET %ZIS("A")="Select LIST Printer: "
SET %ZIS="MQ"
DO ^%ZIS
KILL %ZIS,IOP
IF POP
GOTO KIL
+2 IF $DATA(IO("Q"))
SET FHPGM="F1^FHORD5"
SET FHLST="FHP^SRT"
DO EN2^FH
GOTO KIL
+3 USE IO
DO F1
DO ^%ZISC
KILL %ZIS,IOP
GOTO KIL
KIL KILL ^TMP($JOB)
GOTO KILL^XUSCLEAN
F1 ; List Withholds
+1 DO NOW^%DTC
SET NOW=%
SET DT=NOW\1
SET X1=NOW
SET X2=-3
DO C^%DTC
SET OLD=+X
SET PG=0
DO HDR
KILL ^TMP($JOB)
+2 FOR W1=0:0
SET W1=$ORDER(^FHPT("AW",W1))
IF W1'>0
QUIT
DO DP
IF 'FHP!(D1=FHP)
FOR FHDFN=0:0
SET FHDFN=$ORDER(^FHPT("AW",W1,FHDFN))
IF FHDFN<1
QUIT
SET ADM=$GET(^FHPT("AW",W1,FHDFN))
IF ADM>0
DO F2
+3 SET WRDN=""
FOR A3=0:0
SET WRDN=$ORDER(^TMP($JOB,WRDN))
IF WRDN=""
QUIT
FOR FHDFN=0:0
SET FHDFN=$ORDER(^TMP($JOB,WRDN,FHDFN))
IF FHDFN<1
QUIT
SET X=$GET(^TMP($JOB,WRDN,FHDFN))
DO F3
+4 WRITE !
QUIT
F2 DO PATNAME^FHOMUTL
IF DFN=""
QUIT
+1 SET Y(0)=^DPT(DFN,0)
IF '$DATA(^FHPT(FHDFN,"A",ADM,0))
QUIT
IF $PIECE(^(0),"^",4)
QUIT
DO CUR^FHORD7
IF FHLD=""
QUIT
+2 SET A1=0
FOR K=0:0
SET K=$ORDER(^FHPT(FHDFN,"A",ADM,"AC",K))
IF K<1!(K>NOW)
QUIT
IF $PIECE(^(K,0),"^",2)=FHORD
SET A1=K
+3 SET D2=$PIECE(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),"^",10)
DO PID^FHDPA
+4 SET RM=$EXTRACT(WRDN,1,14)
IF $DATA(^DPT(DFN,.101))
SET RM=RM_"/"_^(.101)
+5 SET ^TMP($JOB,$SELECT(SRT="W":WRDN,1:A1),FHDFN)=$EXTRACT(RM,1,21)_"^"_$PIECE(Y(0),"^",1)_"^"_BID_"^"_A1_"^"_D2_"^"_Y
QUIT
F3 IF $Y>58
DO HDR
WRITE !,$PIECE(X,"^",1),?24,$PIECE(X,"^",2),?55,$PIECE(X,"^",3)
+1 SET D1=$PIECE(X,"^",4)
SET D2=$PIECE(X,"^",5)
+2 SET DTP=D1
DO DTP^FH
WRITE ?64,DTP
IF D2
SET DTP=D2
DO DTP^FH
WRITE ?83,DTP
+3 IF D1<OLD
WRITE ?102,"*"
WRITE ?106,$PIECE(X,"^",6)
QUIT
DP SET WRDN=$PIECE(^FH(119.6,W1,0),"^",1)
SET D1=$PIECE(^(0),"^",8)
QUIT
HDR IF '($EXTRACT(IOST,1,2)'="C-"&'PG)
WRITE @IOF
SET PG=PG+1
WRITE !?44,"N P O / P A S S L I S T",?107,"Page ",PG
+1 WRITE !!
IF FHP
WRITE $PIECE(^FH(119.73,FHP,0),"^",1)
SET DTP=NOW
DO DTP^FH
WRITE ?48,DTP
+2 WRITE !!,"WARD/ROOM",?24,"PATIENT",?56,"ID#",?65,"EFFECTIVE DATE",?84,"EXPIRATION DATE",?102,">3",?106,"REASON",!
QUIT
