- FHORDR ; HISC/REL - Production Diet Recode ;3/28/95 12:09
- ;;5.5;DIETETICS;;Jan 28, 2005
- S FLG=0
- CODE ; Recode diet
- Q:"^^^^"[FHOR I FHOR="1^^^^" S Z=1 G C1
- Q:PDFLG
- S MP=$O(^FH(111.1,"AB",FHOR,0))
- S Z=$P($G(^FH(111.1,+MP,0)),"^",7) G:Z C1
- S M="^" F K1=1:1:5 S Z=$P(FHOR,"^",K1) Q:Z<1 S M=M_+$P(^FH(111,Z,0),"^",5)_"^"
- F LC=0:0 S LC=$O(^FH(116.2,"AR",LC)) Q:LC<1 S X=^(LC) F K1=1:1 S X1=$P(X,"^",K1) Q:X1<1 D REC G:Z C1
- S Z=0 D:FLG MIS
- C1 S:Z $P(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),"^",13)=Z Q
- MIS ; No recoding of diet order
- D PATNAME^FHOMUTL I DFN="" Q
- W !,$P($G(^DPT(DFN,0)),"^",1),", Admission ",ADM,", Diet Order ",FHORD," not recoded" Q
- Q
- REC S Z=$P(X1,":",1),X1=$P(X1,":",2) F K2=1:1 S C=$P(X1," ",K2) Q:C<1 G:M'[("^"_C_"^") R1
- Q
- R1 S Z=0 Q
- SET ; Rebuild 'AR' recode cross-reference
- K M,^FH(116.2,"AR") F K1=0:0 S K1=$O(^FH(116.2,K1)) Q:K1<1 D S1
- S LC=1,X="" F M=0:0 S M=$O(M(M)) Q:M<1 S Z=M(M) D S2
- S:X'="" ^FH(116.2,"AR",LC)=$E(X,2,999) K FHORD,K1,K2,LC,M,X,Z Q
- S1 S X="",M=+$P(^FH(116.2,K1,0),"^",5) Q:'M Q:$D(^FH(116.2,K1,"I"))
- F K2=0:0 S K2=$O(^FH(116.2,K1,"R",K2)) Q:K2<1 S Z=^(K2,0) S:Z X=X_" "_Z
- S:X="" X=" "_K1 S M(M)=K1_":"_$E(X,2,999) Q
- S2 I $L(X)+$L(Z)>245 S ^FH(116.2,"AR",LC)=$E(X,2,999),X="",LC=LC+1
- S X=X_"^"_Z Q
- INP ; Recode all inpatients
- D SET S FLG=1,PDFLG=0
- F W1=0:0 S W1=$O(^FHPT("AW",W1)) Q:W1'>0 F FHDFN=0:0 S FHDFN=$O(^FHPT("AW",W1,FHDFN)) Q:FHDFN<1 S ADM=$G(^FHPT("AW",W1,FHDFN)) D:ADM Z1
- K ADM,C,D,FHDFN,DFN,FHOR,FHORD,FLG,I,K1,K2,LC,M,W1,X,X1,Z Q
- Z1 F FHORD=0:0 S FHORD=$O(^FHPT(FHDFN,"A",ADM,"DI",FHORD)) Q:FHORD<1 D Z2
- Q
- Z2 S Z=$G(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0)),FHOR=$P(Z,"^",2,6) Q:"^^^^"[FHOR D CODE Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHORDR 1712 printed Jan 18, 2025@02:54:57 Page 2
- FHORDR ; HISC/REL - Production Diet Recode ;3/28/95 12:09
- +1 ;;5.5;DIETETICS;;Jan 28, 2005
- +2 SET FLG=0
- CODE ; Recode diet
- +1 if "^^^^"[FHOR
- QUIT
- IF FHOR="1^^^^"
- SET Z=1
- GOTO C1
- +2 if PDFLG
- QUIT
- +3 SET MP=$ORDER(^FH(111.1,"AB",FHOR,0))
- +4 SET Z=$PIECE($GET(^FH(111.1,+MP,0)),"^",7)
- if Z
- GOTO C1
- +5 SET M="^"
- FOR K1=1:1:5
- SET Z=$PIECE(FHOR,"^",K1)
- if Z<1
- QUIT
- SET M=M_+$PIECE(^FH(111,Z,0),"^",5)_"^"
- +6 FOR LC=0:0
- SET LC=$ORDER(^FH(116.2,"AR",LC))
- if LC<1
- QUIT
- SET X=^(LC)
- FOR K1=1:1
- SET X1=$PIECE(X,"^",K1)
- if X1<1
- QUIT
- DO REC
- if Z
- GOTO C1
- +7 SET Z=0
- if FLG
- DO MIS
- C1 if Z
- SET $PIECE(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0),"^",13)=Z
- QUIT
- MIS ; No recoding of diet order
- +1 DO PATNAME^FHOMUTL
- IF DFN=""
- QUIT
- +2 WRITE !,$PIECE($GET(^DPT(DFN,0)),"^",1),", Admission ",ADM,", Diet Order ",FHORD," not recoded"
- QUIT
- +3 QUIT
- REC SET Z=$PIECE(X1,":",1)
- SET X1=$PIECE(X1,":",2)
- FOR K2=1:1
- SET C=$PIECE(X1," ",K2)
- if C<1
- QUIT
- if M'[("^"_C_"^")
- GOTO R1
- +1 QUIT
- R1 SET Z=0
- QUIT
- SET ; Rebuild 'AR' recode cross-reference
- +1 KILL M,^FH(116.2,"AR")
- FOR K1=0:0
- SET K1=$ORDER(^FH(116.2,K1))
- if K1<1
- QUIT
- DO S1
- +2 SET LC=1
- SET X=""
- FOR M=0:0
- SET M=$ORDER(M(M))
- if M<1
- QUIT
- SET Z=M(M)
- DO S2
- +3 if X'=""
- SET ^FH(116.2,"AR",LC)=$EXTRACT(X,2,999)
- KILL FHORD,K1,K2,LC,M,X,Z
- QUIT
- S1 SET X=""
- SET M=+$PIECE(^FH(116.2,K1,0),"^",5)
- if 'M
- QUIT
- if $DATA(^FH(116.2,K1,"I"))
- QUIT
- +1 FOR K2=0:0
- SET K2=$ORDER(^FH(116.2,K1,"R",K2))
- if K2<1
- QUIT
- SET Z=^(K2,0)
- if Z
- SET X=X_" "_Z
- +2 if X=""
- SET X=" "_K1
- SET M(M)=K1_":"_$EXTRACT(X,2,999)
- QUIT
- S2 IF $LENGTH(X)+$LENGTH(Z)>245
- SET ^FH(116.2,"AR",LC)=$EXTRACT(X,2,999)
- SET X=""
- SET LC=LC+1
- +1 SET X=X_"^"_Z
- QUIT
- INP ; Recode all inpatients
- +1 DO SET
- SET FLG=1
- SET PDFLG=0
- +2 FOR W1=0:0
- SET W1=$ORDER(^FHPT("AW",W1))
- if W1'>0
- QUIT
- FOR FHDFN=0:0
- SET FHDFN=$ORDER(^FHPT("AW",W1,FHDFN))
- if FHDFN<1
- QUIT
- SET ADM=$GET(^FHPT("AW",W1,FHDFN))
- if ADM
- DO Z1
- +3 KILL ADM,C,D,FHDFN,DFN,FHOR,FHORD,FLG,I,K1,K2,LC,M,W1,X,X1,Z
- QUIT
- Z1 FOR FHORD=0:0
- SET FHORD=$ORDER(^FHPT(FHDFN,"A",ADM,"DI",FHORD))
- if FHORD<1
- QUIT
- DO Z2
- +1 QUIT
- Z2 SET Z=$GET(^FHPT(FHDFN,"A",ADM,"DI",FHORD,0))
- SET FHOR=$PIECE(Z,"^",2,6)
- if "^^^^"[FHOR
- QUIT
- DO CODE
- QUIT