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 Oct 16, 2024@17:48:21 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
