- FHDCR2 ; HISC/REL/NCA - Find Order Changes ;4/20/95 11:33
- ;;5.5;DIETETICS;;Jan 28, 2005
- EVT ; Find order changes,SF,FP,Isolation,SO,Location
- ; Except Allergies.
- I SF,$P($G(^FHPT(FHDFN,"A",ADM,"SF",+SF,0)),"^",2)>FHD,$P($G(^FHPT(FHDFN,"A",ADM,"SF",+SF,0)),"^",34)'="Y" S FLG2=1 Q
- F KK=FHD-.0001:0 S KK=$O(^FH(119.8,"AP",FHDFN,KK)) Q:KK>TIM!(KK<1) F DA=0:0 S DA=$O(^FH(119.8,"AP",FHDFN,KK,DA)) Q:DA<1 D Q:FLG2
- .S Z=$G(^FH(119.8,DA,0)) Q:Z="" S D1=$P(Z,"^",2),TYP=$P(Z,"^",5),ACT=$P(Z,"^",6)
- .I TYP="L" D Q
- ..I "AT"[ACT S FLG2=1 Q
- ..Q
- .I TYP="D" Q
- .I TYP="M" Q
- .I TYP="I" S FLG2=1 Q
- .I TYP="T" Q
- .I TYP="O" Q
- .I TYP="P" S FLG2=1 Q
- .I TYP="S" S FLG2=1 Q
- .Q
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHDCR2 697 printed Feb 18, 2025@23:13:53 Page 2
- FHDCR2 ; HISC/REL/NCA - Find Order Changes ;4/20/95 11:33
- +1 ;;5.5;DIETETICS;;Jan 28, 2005
- EVT ; Find order changes,SF,FP,Isolation,SO,Location
- +1 ; Except Allergies.
- +2 IF SF
- IF $PIECE($GET(^FHPT(FHDFN,"A",ADM,"SF",+SF,0)),"^",2)>FHD
- IF $PIECE($GET(^FHPT(FHDFN,"A",ADM,"SF",+SF,0)),"^",34)'="Y"
- SET FLG2=1
- QUIT
- +3 FOR KK=FHD-.0001:0
- SET KK=$ORDER(^FH(119.8,"AP",FHDFN,KK))
- if KK>TIM!(KK<1)
- QUIT
- FOR DA=0:0
- SET DA=$ORDER(^FH(119.8,"AP",FHDFN,KK,DA))
- if DA<1
- QUIT
- Begin DoDot:1
- +4 SET Z=$GET(^FH(119.8,DA,0))
- if Z=""
- QUIT
- SET D1=$PIECE(Z,"^",2)
- SET TYP=$PIECE(Z,"^",5)
- SET ACT=$PIECE(Z,"^",6)
- +5 IF TYP="L"
- Begin DoDot:2
- +6 IF "AT"[ACT
- SET FLG2=1
- QUIT
- +7 QUIT
- End DoDot:2
- QUIT
- +8 IF TYP="D"
- QUIT
- +9 IF TYP="M"
- QUIT
- +10 IF TYP="I"
- SET FLG2=1
- QUIT
- +11 IF TYP="T"
- QUIT
- +12 IF TYP="O"
- QUIT
- +13 IF TYP="P"
- SET FLG2=1
- QUIT
- +14 IF TYP="S"
- SET FLG2=1
- QUIT
- +15 QUIT
- End DoDot:1
- if FLG2
- QUIT
- +16 QUIT
