- FHORC1 ; HISC/REL - Review Active Consults ;4/26/93 14:48
- ;;5.5;DIETETICS;;Jan 28, 2005
- E1 R !!,"Select CLINICIAN (or ALL): ",X:DTIME G:'$T!("^"[X) KIL D:X="all" TR^FH I X="ALL" S FHDZ=0
- E K DIC S DIC="^VA(200,",DIC(0)="QEM" D ^DIC G:Y<1 E1 S FHDZ=+Y
- E2 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="Q0^FHORC1",FHLST="FHDZ" D EN2^FH G:'FHDZ KIL G E1
- U IO D Q0 D ^%ZISC K %ZIS,IOP G KIL:'FHDZ,E1
- Q0 ; Display Active Consults
- W:$E(IOST,1,2)="C-" @IOF W !?25,"A C T I V E C O N S U L T S"
- I FHDZ S X=$P(^VA(200,FHDZ,0),"^",1) W !!?(80-$L(X)\2),X
- W !!,"Date/Time Ordered",?19,"Request",?31,"ID#",?40,"Patient",?62,$S(FHDZ:"Ward",1:"Clinician"),!
- Q1 S FHDFN=0,X1=FHDZ I FHDZ G Q3
- Q2 S X1=$O(^FHPT("ADRU",X1)) G:X1<1 Q10 S FHDFN=0
- Q3 S FHDFN=$O(^FHPT("ADRU",X1,FHDFN)) G:FHDFN="" Q2:'FHDZ,Q10 S ADM=""
- Q4 S ADM=$O(^FHPT("ADRU",X1,FHDFN,ADM)) G:ADM="" Q3 S DR=""
- Q5 S DR=$O(^FHPT("ADRU",X1,FHDFN,ADM,DR)) G:DR="" Q4
- D PATNAME^FHOMUTL I DFN="" Q
- S Y=^FHPT(FHDFN,"A",ADM,"DR",DR,0)
- S REQ=$P(Y,"^",2),DTE=$P(Y,"^",1),DIET=$P(Y,"^",5)
- I '$D(^DGPM(ADM,0)) K ^FHPT("ADRU",X1,FHDFN) S $P(^FHPT(FHDFN,"A",ADM,"DR",DR,0),"^",8)="X" G Q5
- S Y=^DPT(DFN,0),PNAM=$P(Y,"^",1),FHWRD=$P($G(^FHPT(FHDFN,"A",ADM,0)),"^",8) D PID^FHDPA
- I FHDZ S WARD=$S(FHWRD:$P($G(^FH(119.6,FHWRD,0)),"^",1),1:"Discharged") I $P($G(^DGPM(ADM,0)),"^",17) S WARD="Discharged"
- I 'FHDZ S WARD=$P(^VA(200,DIET,0),"^",1)
- S REQ=$P($G(^FH(119.5,REQ,0)),"^",2)
- S DTP=DTE D DTP^FH
- W !,DTP,?19,REQ,?31,BID,?40,$E(PNAM,1,20),?62,$E(WARD,1,17) G Q5
- Q10 I IOST?1"C-".E R !!,"Press RETURN to Continue ",X:DTIME Q:'$T!(X["^")
- W ! Q
- KIL G KILL^XUSCLEAN
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHORC1 1712 printed Mar 13, 2025@20:57:55 Page 2
- FHORC1 ; HISC/REL - Review Active Consults ;4/26/93 14:48
- +1 ;;5.5;DIETETICS;;Jan 28, 2005
- E1 READ !!,"Select CLINICIAN (or ALL): ",X:DTIME
- if '$TEST!("^"[X)
- GOTO KIL
- if X="all"
- DO TR^FH
- IF X="ALL"
- SET FHDZ=0
- +1 IF '$TEST
- KILL DIC
- SET DIC="^VA(200,"
- SET DIC(0)="QEM"
- DO ^DIC
- if Y<1
- GOTO E1
- SET FHDZ=+Y
- E2 WRITE !
- KILL IOP,%ZIS
- SET %ZIS("A")="Select LIST PRINTER: "
- SET %ZIS="MQ"
- DO ^%ZIS
- KILL %ZIS,IOP
- if POP
- GOTO KIL
- +1 IF $DATA(IO("Q"))
- SET FHPGM="Q0^FHORC1"
- SET FHLST="FHDZ"
- DO EN2^FH
- if 'FHDZ
- GOTO KIL
- GOTO E1
- +2 USE IO
- DO Q0
- DO ^%ZISC
- KILL %ZIS,IOP
- if 'FHDZ
- GOTO KIL
- GOTO E1
- Q0 ; Display Active Consults
- +1 if $EXTRACT(IOST,1,2)="C-"
- WRITE @IOF
- WRITE !?25,"A C T I V E C O N S U L T S"
- +2 IF FHDZ
- SET X=$PIECE(^VA(200,FHDZ,0),"^",1)
- WRITE !!?(80-$LENGTH(X)\2),X
- +3 WRITE !!,"Date/Time Ordered",?19,"Request",?31,"ID#",?40,"Patient",?62,$SELECT(FHDZ:"Ward",1:"Clinician"),!
- Q1 SET FHDFN=0
- SET X1=FHDZ
- IF FHDZ
- GOTO Q3
- Q2 SET X1=$ORDER(^FHPT("ADRU",X1))
- if X1<1
- GOTO Q10
- SET FHDFN=0
- Q3 SET FHDFN=$ORDER(^FHPT("ADRU",X1,FHDFN))
- if FHDFN=""
- if 'FHDZ
- GOTO Q2
- GOTO Q10
- SET ADM=""
- Q4 SET ADM=$ORDER(^FHPT("ADRU",X1,FHDFN,ADM))
- if ADM=""
- GOTO Q3
- SET DR=""
- Q5 SET DR=$ORDER(^FHPT("ADRU",X1,FHDFN,ADM,DR))
- if DR=""
- GOTO Q4
- +1 DO PATNAME^FHOMUTL
- IF DFN=""
- QUIT
- +2 SET Y=^FHPT(FHDFN,"A",ADM,"DR",DR,0)
- +3 SET REQ=$PIECE(Y,"^",2)
- SET DTE=$PIECE(Y,"^",1)
- SET DIET=$PIECE(Y,"^",5)
- +4 IF '$DATA(^DGPM(ADM,0))
- KILL ^FHPT("ADRU",X1,FHDFN)
- SET $PIECE(^FHPT(FHDFN,"A",ADM,"DR",DR,0),"^",8)="X"
- GOTO Q5
- +5 SET Y=^DPT(DFN,0)
- SET PNAM=$PIECE(Y,"^",1)
- SET FHWRD=$PIECE($GET(^FHPT(FHDFN,"A",ADM,0)),"^",8)
- DO PID^FHDPA
- +6 IF FHDZ
- SET WARD=$SELECT(FHWRD:$PIECE($GET(^FH(119.6,FHWRD,0)),"^",1),1:"Discharged")
- IF $PIECE($GET(^DGPM(ADM,0)),"^",17)
- SET WARD="Discharged"
- +7 IF 'FHDZ
- SET WARD=$PIECE(^VA(200,DIET,0),"^",1)
- +8 SET REQ=$PIECE($GET(^FH(119.5,REQ,0)),"^",2)
- +9 SET DTP=DTE
- DO DTP^FH
- +10 WRITE !,DTP,?19,REQ,?31,BID,?40,$EXTRACT(PNAM,1,20),?62,$EXTRACT(WARD,1,17)
- GOTO Q5
- Q10 IF IOST?1"C-".E
- READ !!,"Press RETURN to Continue ",X:DTIME
- if '$TEST!(X["^")
- QUIT
- +1 WRITE !
- QUIT
- KIL GOTO KILL^XUSCLEAN
