Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: FHORD5

FHORD5.m

Go to the documentation of this file.
  1. FHORD5 ; HISC/REL/NCA - Withhold Lists ;3/16/95 14:21
  1. ;;5.5;DIETETICS;;Jan 28, 2005
  1. W @IOF,!!?27,"N P O / P A S S L I S T",!!
  1. S FHP=$O(^FH(119.73,0)) I FHP'<1,$O(^FH(119.73,FHP))<1 S FHP=0 G R1
  1. R0 R !!,"Select COMMUNICATION OFFICE (or ALL): ",X:DTIME G:'$T!("^"[X) KIL D:X="all" TR^FH I X="ALL" S FHP=0
  1. E K DIC S DIC="^FH(119.73,",DIC(0)="EMQ" D ^DIC G:Y<1 R0 S FHP=+Y
  1. 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
  1. I $P("WARD",SRT,1)'="",$P("DATE/TIME",SRT,1)'="" W *7," Enter W or D" G R1
  1. S SRT=$E(SRT,1)
  1. R2 W !!,"The list requires a 132 column printer.",!
  1. W ! K IOP,%ZIS S %ZIS("A")="Select LIST Printer: ",%ZIS="MQ" D ^%ZIS K %ZIS,IOP G:POP KIL
  1. I $D(IO("Q")) S FHPGM="F1^FHORD5",FHLST="FHP^SRT" D EN2^FH G KIL
  1. U IO D F1 D ^%ZISC K %ZIS,IOP G KIL
  1. KIL K ^TMP($J) G KILL^XUSCLEAN
  1. F1 ; List Withholds
  1. 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)
  1. 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
  1. 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
  1. W ! Q
  1. F2 D PATNAME^FHOMUTL I DFN="" Q
  1. S Y(0)=^DPT(DFN,0) Q:'$D(^FHPT(FHDFN,"A",ADM,0)) Q:$P(^(0),"^",4) D CUR^FHORD7 Q:FHLD=""
  1. 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
  1. S D2=$P(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),"^",10) D PID^FHDPA
  1. S RM=$E(WRDN,1,14) I $D(^DPT(DFN,.101)) S RM=RM_"/"_^(.101)
  1. S ^TMP($J,$S(SRT="W":WRDN,1:A1),FHDFN)=$E(RM,1,21)_"^"_$P(Y(0),"^",1)_"^"_BID_"^"_A1_"^"_D2_"^"_Y Q
  1. F3 D:$Y>58 HDR W !,$P(X,"^",1),?24,$P(X,"^",2),?55,$P(X,"^",3)
  1. S D1=$P(X,"^",4),D2=$P(X,"^",5)
  1. S DTP=D1 D DTP^FH W ?64,DTP I D2 S DTP=D2 D DTP^FH W ?83,DTP
  1. W:D1<OLD ?102,"*" W ?106,$P(X,"^",6) Q
  1. DP S WRDN=$P(^FH(119.6,W1,0),"^",1),D1=$P(^(0),"^",8) Q
  1. 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
  1. W !! W:FHP $P(^FH(119.73,FHP,0),"^",1) S DTP=NOW D DTP^FH W ?48,DTP
  1. W !!,"WARD/ROOM",?24,"PATIENT",?56,"ID#",?65,"EFFECTIVE DATE",?84,"EXPIRATION DATE",?102,">3",?106,"REASON",! Q