- FHORD4 ; HISC/REL/NCA - Isolation/Precaution ;10/11/00 07:52
- ;;5.5;DIETETICS;;Jan 28, 2005
- S ALL=0 D ^FHDPA G:'DFN KIL G:'FHDFN KIL
- D NOW^%DTC S NOW=% K %,%H,%I
- I $P(^FHPT(FHDFN,"A",ADM,0),"^",10)'="" G F1
- K DIC S DIC="^FH(119.4,",DIC(0)="AEQM" W ! D ^DIC G:Y<1 KIL S IS=+Y
- S FHNOW=NOW D FIL,ISO^FHWOR61 S NOW=FHNOW
- S TYP=$P(^FHPT(FHDFN,"A",ADM,0),"^",5) I TYP'="C",TYP'="D" G S2
- S1 R !!,"Patient is on CAFETERIA/DINING ROOM Service. Change to TRAY? YES// ",X:DTIME G:'$T!(X["^") KIL
- S:X="" X="Y" D TR^FH I $P("YES",X,1)'="",$P("NO",X,1)'="" W *7," Answer YES or NO" G S1
- G:X?1"N".E S2 D CUR^FHORD7 I "^^^^"[FHOR S $P(^FHPT(FHDFN,"A",ADM,0),"^",5)="T" G S2
- S TYP="T",D2=$P(X,"^",10),(D3,D4)=0,COM="",D1=NOW,DT=NOW\1 D STR^FHORD7
- S2 ;
- W " ... done" G KIL
- F1 S X=$P(^FHPT(FHDFN,"A",ADM,0),"^",10)
- W !!,"Isolation/Precaution Type is: ",$P($G(^FH(119.4,X,0)),"^",1)
- F2 R !!,"Do you wish to remove? (Y/N) ",X:DTIME G:'$T!(X["^") KIL S:X="" X="*" D TR^FH I $P("YES",X,1)'="",$P("NO",X,1)'="" W *7," Answer YES or NO" G F2
- I X?1"Y".E D CAN S FHORN=$P(^FHPT(FHDFN,"A",ADM,0),"^",13) D:FHORN>0 CODE^FHWOR61 W " ...removed" G KIL
- W " ... no change made" G KIL
- FIL ; File Isolation
- S $P(^FHPT(FHDFN,"A",ADM,0),"^",10)=IS,X=^FH(119.4,IS,0)
- S ^FHPT("AIS",FHDFN,ADM)=""
- S EVT="I^O^"_IS D ^FHORX Q
- CAN ; Cancel Isolation
- S IS=$P(^FHPT(FHDFN,"A",ADM,0),"^",10),$P(^(0),"^",10)="" K ^FHPT("AIS",FHDFN,ADM)
- S EVT="I^C^"_IS D ^FHORX Q
- KIL K %DT,ADM,ALL,BY,C,COM,D1,D2,D3,D4,DA,FHDFN,DFN,DHD,DIC,DIE,DR,FHDU,FHLD,FHORD,FHDR,FHOR,FHORN,FHWF,FHPV,FLDS,FR,I,IS,L,NOW,POP,TO,TYP,WARD,X,X1,Y Q
- EN1 ; Enter/Edit Isolation/Precaution Types
- K DIC S (DIC,DIE)="^FH(119.4,",DIC(0)="AEQLM",DIC("DR")=".01",DLAYGO=119.4 W ! D ^DIC K DIC,DLAYGO G KIL:"^"[X!$D(DTOUT),EN1:Y<1
- S DA=+Y,DR=".01:99" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=119.4 D ^DIE K DA,DIE,DIDEL,DR G EN1
- EN2 ; List Isolation/Precaution Types
- W ! S L=0,DIC="^FH(119.4,",FLDS="[FHISLST]",BY="NAME"
- S (FR,TO)="",DHD="ISOLATION/PRECAUTION TYPES" D EN1^DIP,RSET G KIL
- RSET K %ZIS S IOP="" D ^%ZIS K %ZIS,IOP,BY,DA,DHD,DIC,DIE,DR,FLDS,FR,L,TO,X,Y Q
- SETVAR ; Set Date in HL7 format
- S FHIDT=$$FMTHL7^XLFDT(NOW) ;HL7 date format
- S FILL="I"_";"_ADM_";"_IS D SITE^FH
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHORD4 2255 printed Jan 18, 2025@02:54:42 Page 2
- FHORD4 ; HISC/REL/NCA - Isolation/Precaution ;10/11/00 07:52
- +1 ;;5.5;DIETETICS;;Jan 28, 2005
- +2 SET ALL=0
- DO ^FHDPA
- if 'DFN
- GOTO KIL
- if 'FHDFN
- GOTO KIL
- +3 DO NOW^%DTC
- SET NOW=%
- KILL %,%H,%I
- +4 IF $PIECE(^FHPT(FHDFN,"A",ADM,0),"^",10)'=""
- GOTO F1
- +5 KILL DIC
- SET DIC="^FH(119.4,"
- SET DIC(0)="AEQM"
- WRITE !
- DO ^DIC
- if Y<1
- GOTO KIL
- SET IS=+Y
- +6 SET FHNOW=NOW
- DO FIL
- DO ISO^FHWOR61
- SET NOW=FHNOW
- +7 SET TYP=$PIECE(^FHPT(FHDFN,"A",ADM,0),"^",5)
- IF TYP'="C"
- IF TYP'="D"
- GOTO S2
- S1 READ !!,"Patient is on CAFETERIA/DINING ROOM Service. Change to TRAY? YES// ",X:DTIME
- if '$TEST!(X["^")
- GOTO KIL
- +1 if X=""
- SET X="Y"
- DO TR^FH
- IF $PIECE("YES",X,1)'=""
- IF $PIECE("NO",X,1)'=""
- WRITE *7," Answer YES or NO"
- GOTO S1
- +2 if X?1"N".E
- GOTO S2
- DO CUR^FHORD7
- IF "^^^^"[FHOR
- SET $PIECE(^FHPT(FHDFN,"A",ADM,0),"^",5)="T"
- GOTO S2
- +3 SET TYP="T"
- SET D2=$PIECE(X,"^",10)
- SET (D3,D4)=0
- SET COM=""
- SET D1=NOW
- SET DT=NOW\1
- DO STR^FHORD7
- S2 ;
- +1 WRITE " ... done"
- GOTO KIL
- F1 SET X=$PIECE(^FHPT(FHDFN,"A",ADM,0),"^",10)
- +1 WRITE !!,"Isolation/Precaution Type is: ",$PIECE($GET(^FH(119.4,X,0)),"^",1)
- F2 READ !!,"Do you wish to remove? (Y/N) ",X:DTIME
- if '$TEST!(X["^")
- GOTO KIL
- if X=""
- SET X="*"
- DO TR^FH
- IF $PIECE("YES",X,1)'=""
- IF $PIECE("NO",X,1)'=""
- WRITE *7," Answer YES or NO"
- GOTO F2
- +1 IF X?1"Y".E
- DO CAN
- SET FHORN=$PIECE(^FHPT(FHDFN,"A",ADM,0),"^",13)
- if FHORN>0
- DO CODE^FHWOR61
- WRITE " ...removed"
- GOTO KIL
- +2 WRITE " ... no change made"
- GOTO KIL
- FIL ; File Isolation
- +1 SET $PIECE(^FHPT(FHDFN,"A",ADM,0),"^",10)=IS
- SET X=^FH(119.4,IS,0)
- +2 SET ^FHPT("AIS",FHDFN,ADM)=""
- +3 SET EVT="I^O^"_IS
- DO ^FHORX
- QUIT
- CAN ; Cancel Isolation
- +1 SET IS=$PIECE(^FHPT(FHDFN,"A",ADM,0),"^",10)
- SET $PIECE(^(0),"^",10)=""
- KILL ^FHPT("AIS",FHDFN,ADM)
- +2 SET EVT="I^C^"_IS
- DO ^FHORX
- QUIT
- KIL KILL %DT,ADM,ALL,BY,C,COM,D1,D2,D3,D4,DA,FHDFN,DFN,DHD,DIC,DIE,DR,FHDU,FHLD,FHORD,FHDR,FHOR,FHORN,FHWF,FHPV,FLDS,FR,I,IS,L,NOW,POP,TO,TYP,WARD,X,X1,Y
- QUIT
- EN1 ; Enter/Edit Isolation/Precaution Types
- +1 KILL DIC
- SET (DIC,DIE)="^FH(119.4,"
- SET DIC(0)="AEQLM"
- SET DIC("DR")=".01"
- SET DLAYGO=119.4
- WRITE !
- DO ^DIC
- KILL DIC,DLAYGO
- if "^"[X!$DATA(DTOUT)
- GOTO KIL
- if Y<1
- GOTO EN1
- +2 SET DA=+Y
- SET DR=".01:99"
- if $DATA(^XUSEC("FHMGR",DUZ))
- SET DIDEL=119.4
- DO ^DIE
- KILL DA,DIE,DIDEL,DR
- GOTO EN1
- EN2 ; List Isolation/Precaution Types
- +1 WRITE !
- SET L=0
- SET DIC="^FH(119.4,"
- SET FLDS="[FHISLST]"
- SET BY="NAME"
- +2 SET (FR,TO)=""
- SET DHD="ISOLATION/PRECAUTION TYPES"
- DO EN1^DIP
- DO RSET
- GOTO KIL
- RSET KILL %ZIS
- SET IOP=""
- DO ^%ZIS
- KILL %ZIS,IOP,BY,DA,DHD,DIC,DIE,DR,FLDS,FR,L,TO,X,Y
- QUIT
- SETVAR ; Set Date in HL7 format
- +1 ;HL7 date format
- SET FHIDT=$$FMTHL7^XLFDT(NOW)
- +2 SET FILL="I"_";"_ADM_";"_IS
- DO SITE^FH
- +3 QUIT