- FHORC ; HISC/REL - Dietetic Consults ;9/4/96 09:22 ;
- ;;5.5;DIETETICS;**8**;Jan 28, 2005;Build 28
- EN1 ; Order Consult
- S ALL=0 D ^FHDPA G:'DFN KIL G:'FHDFN KIL D ORD G:'$D(DFN) KIL D FIL G KIL
- ORD ; Get Order
- W ! F K=0:0 S K=$O(^FH(119.5,K)) Q:K<1 W:'$D(^FH(119.5,K,"I")) !,$P(^(0),"^",1)
- R1 W ! K DIC S DIC="^FH(119.5,",DIC(0)="AEQZM" D ^DIC G AB:U[X!$D(DTOUT),R1:Y<1 S REQ=+Y
- R2 R !,"Comment: ",COM:DTIME G:'$T!(COM["^") AB I COM'?.ANP W *7," ??" G R2
- I $L(COM)>80!(COM?1"?".E) W *7,!,"Enter 1-80 character comment" G R2
- R4 R !,"Ok to Enter Request? Y// ",YN:DTIME G AB:'$T!(YN["^") S:YN="" YN="Y" S X=YN D TR^FH S YN=X I $P("YES",YN,1)'="",$P("NO",YN,1)'="" W *7," Answer YES or NO" G R4
- G:YN'?1"Y".E AB Q
- FIL ; File Order
- L +^FHPT(FHDFN,"A",ADM,"DR",0) S:'$D(^FHPT(FHDFN,"A",ADM,"DR",0)) ^FHPT(FHDFN,"A",ADM,"DR",0)="^115.03^^"
- S DR=$P(^FHPT(FHDFN,"A",ADM,"DR",0),"^",3)+1,$P(^(0),"^",3,4)=DR_"^"_DR L -^FHPT(FHDFN,"A",ADM,"DR",0)
- D NOW^%DTC S NOW=% D CHK
- S ^FHPT(FHDFN,"A",ADM,"DR",DR,0)=NOW_"^"_REQ_"^"_COM_"^^"_XMKK_"^^"_DUZ_"^A"
- S ^FHPT("ADR",NOW,FHDFN,ADM,DR)="",^FHPT("ADRU",XMKK,FHDFN,ADM,DR)=""
- D POST Q
- CHK ; Get Clinician
- S WRD=$P($G(^FHPT(FHDFN,"A",ADM,0)),"^",8) G:WRD<1 RNO
- G:'$D(^FH(119.6,WRD)) RNO
- S XMKK=$P($G(^FH(119.5,+REQ,0)),"^",6)
- F FHXMKK=0:0 S FHXMKK=$O(^FH(119.6,WRD,2,"B",FHXMKK)) Q:FHXMKK'>0 D
- .S XMY(FHXMKK)=""
- I XMKK<1 S XMKK=$O(XMY("")) G:XMKK<1 RNO
- Q
- RNO S XMKK=$O(^XUSEC("FHMGR",0)) S:XMKK<1 XMKK=.5 Q
- AB W *7,!!,"Consult entry is TERMINATED - No request entered!"
- KIL K %,%H,%I,A,G,I,XMKK,WARD,WRD,ADM,ALL,COM,DA,FHDFN,FHXMKK,DFN,DIC,DR,FHPV,K,NOW,REQ,X,Y,YN Q
- POST ; Generate Bulletin
- S XMB="FHDIREQ" I '$D(XMY(XMKK)) S XMY(XMKK)=""
- S XMB(1)=$P(^FH(119.5,REQ,0),"^",1),XMB(2)=$S($D(^DPT(DFN,.101)):^(.101),1:"unknown")
- S XMB(3)=$P(^DPT(DFN,0),"^",1),XMB(4)=WARD,XMB(5)=COM D ^XMB K XMB,XMY,XMM,XMDT Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHORC 1893 printed Jan 18, 2025@02:54:29 Page 2
- FHORC ; HISC/REL - Dietetic Consults ;9/4/96 09:22 ;
- +1 ;;5.5;DIETETICS;**8**;Jan 28, 2005;Build 28
- EN1 ; Order Consult
- +1 SET ALL=0
- DO ^FHDPA
- if 'DFN
- GOTO KIL
- if 'FHDFN
- GOTO KIL
- DO ORD
- if '$DATA(DFN)
- GOTO KIL
- DO FIL
- GOTO KIL
- ORD ; Get Order
- +1 WRITE !
- FOR K=0:0
- SET K=$ORDER(^FH(119.5,K))
- if K<1
- QUIT
- if '$DATA(^FH(119.5,K,"I"))
- WRITE !,$PIECE(^(0),"^",1)
- R1 WRITE !
- KILL DIC
- SET DIC="^FH(119.5,"
- SET DIC(0)="AEQZM"
- DO ^DIC
- if U[X!$DATA(DTOUT)
- GOTO AB
- if Y<1
- GOTO R1
- SET REQ=+Y
- R2 READ !,"Comment: ",COM:DTIME
- if '$TEST!(COM["^")
- GOTO AB
- IF COM'?.ANP
- WRITE *7," ??"
- GOTO R2
- +1 IF $LENGTH(COM)>80!(COM?1"?".E)
- WRITE *7,!,"Enter 1-80 character comment"
- GOTO R2
- R4 READ !,"Ok to Enter Request? Y// ",YN:DTIME
- if '$TEST!(YN["^")
- GOTO AB
- if YN=""
- SET YN="Y"
- SET X=YN
- DO TR^FH
- SET YN=X
- IF $PIECE("YES",YN,1)'=""
- IF $PIECE("NO",YN,1)'=""
- WRITE *7," Answer YES or NO"
- GOTO R4
- +1 if YN'?1"Y".E
- GOTO AB
- QUIT
- FIL ; File Order
- +1 LOCK +^FHPT(FHDFN,"A",ADM,"DR",0)
- if '$DATA(^FHPT(FHDFN,"A",ADM,"DR",0))
- SET ^FHPT(FHDFN,"A",ADM,"DR",0)="^115.03^^"
- +2 SET DR=$PIECE(^FHPT(FHDFN,"A",ADM,"DR",0),"^",3)+1
- SET $PIECE(^(0),"^",3,4)=DR_"^"_DR
- LOCK -^FHPT(FHDFN,"A",ADM,"DR",0)
- +3 DO NOW^%DTC
- SET NOW=%
- DO CHK
- +4 SET ^FHPT(FHDFN,"A",ADM,"DR",DR,0)=NOW_"^"_REQ_"^"_COM_"^^"_XMKK_"^^"_DUZ_"^A"
- +5 SET ^FHPT("ADR",NOW,FHDFN,ADM,DR)=""
- SET ^FHPT("ADRU",XMKK,FHDFN,ADM,DR)=""
- +6 DO POST
- QUIT
- CHK ; Get Clinician
- +1 SET WRD=$PIECE($GET(^FHPT(FHDFN,"A",ADM,0)),"^",8)
- if WRD<1
- GOTO RNO
- +2 if '$DATA(^FH(119.6,WRD))
- GOTO RNO
- +3 SET XMKK=$PIECE($GET(^FH(119.5,+REQ,0)),"^",6)
- +4 FOR FHXMKK=0:0
- SET FHXMKK=$ORDER(^FH(119.6,WRD,2,"B",FHXMKK))
- if FHXMKK'>0
- QUIT
- Begin DoDot:1
- +5 SET XMY(FHXMKK)=""
- End DoDot:1
- +6 IF XMKK<1
- SET XMKK=$ORDER(XMY(""))
- if XMKK<1
- GOTO RNO
- +7 QUIT
- RNO SET XMKK=$ORDER(^XUSEC("FHMGR",0))
- if XMKK<1
- SET XMKK=.5
- QUIT
- AB WRITE *7,!!,"Consult entry is TERMINATED - No request entered!"
- KIL KILL %,%H,%I,A,G,I,XMKK,WARD,WRD,ADM,ALL,COM,DA,FHDFN,FHXMKK,DFN,DIC,DR,FHPV,K,NOW,REQ,X,Y,YN
- QUIT
- POST ; Generate Bulletin
- +1 SET XMB="FHDIREQ"
- IF '$DATA(XMY(XMKK))
- SET XMY(XMKK)=""
- +2 SET XMB(1)=$PIECE(^FH(119.5,REQ,0),"^",1)
- SET XMB(2)=$SELECT($DATA(^DPT(DFN,.101)):^(.101),1:"unknown")
- +3 SET XMB(3)=$PIECE(^DPT(DFN,0),"^",1)
- SET XMB(4)=WARD
- SET XMB(5)=COM
- DO ^XMB
- KILL XMB,XMY,XMM,XMDT
- QUIT