- FHASP1 ; HISC/REL/JH - Nutrition Profile (cont) ;5/2/01 10:14
- ;;5.5;DIETETICS;**8,9**;Jan 28, 2005;Build 7
- ;
- I '$G(FHET) S X="T-365",%DT="XT" D ^%DT S FHET=Y K %DT
- S DTP=FHET D DTP^FH S FHENDATE=DTP
- S N1=0
- W !!?22,"Dietetic Encounters since ",FHENDATE
- F FHET=FHET:0 S FHET=$O(^FHEN("AP",DFN,FHET)) Q:FHET<1!(ANS="^") F ASN=0:0 S ASN=$O(^FHEN("AP",DFN,FHET,ASN)) Q:ASN<1 D:$Y'<S1 HF^FHASP Q:ANS="^" D LST
- Q:ANS="^"
- I 'N1 W !!?5,"No Encounters recorded since ",FHENDATE
- S FHZ115="P"_DFN D CHECK^FHOMDPA I FHDFN="" Q
- S FADM=$O(^FHPT(FHDFN,"A",""),-1) S FADM=$S($G(ADM):$G(ADM),FADM:FADM,1:"") G:FADM="" F1
- D:$Y'<(S1-6) HF^FHASP Q:ANS="^" W !!?28,$S($G(ADM):"Current",1:"Last")," Admission Monitors" S N1=0
- ; F NDT=0:0 S NDT=$O(^FHPT(FHDFN,"A",FADM,"MO","AC",NDT)) Q:NDT<1 F K=0:0 S K=$O(^FHPT(FHDFN,"A",FADM,"MO","AC",NDT,K)) Q:K<1 D MO
- S FHTTLM="",FHTTLM=$P($G(^FHPT(FHDFN,"A",FADM,"MO",0)),U,3)
- I FHTTLM="" W !,"No Monitors on file." G F1
- S FHMONS=$S(FHTTLM-FHNUM<0:0,1:FHTTLM-FHNUM)
- F NDT=FHMONS:0 S NDT=$O(^FHPT(FHDFN,"A",FADM,"MO",NDT)) Q:NDT<1!(ANS="^") S K=NDT D MO
- Q:ANS="^" I 'N1 W !,"No Monitors on file."
- F1 D:$Y'<(S1-6) HF^FHASP Q:ANS="^" W !!?32,"Food Preferences" D DISP
- W !!?27,"Future Clinic Appointments" S N1=0
- ;
- ;patch #41
- ;F NDT=NOW:0 S NDT=$O(^DPT(DFN,"S",NDT)) Q:NDT'>0 S Z=^(NDT,0) I "I"[$P(Z,"^",2) D CLIN Q:ANS="^"
- K ^TMP($J)
- S FHCNT=""
- D GETAPPT^SDAMA201(DFN,"1;2;12","R",DT,,.FHCNT,"")
- G:'$D(^TMP($J,"SDAMA201","GETAPPT")) NOAPP
- I $D(^TMP($J,"SDAMA201","GETAPPT")) S FHTMP=$NA(^TMP($J,"SDAMA201","GETAPPT"))
- I $D(@FHTMP@("ERROR")) D PRERR
- I $G(FHCNT) F FHI=0:0 S FHI=$O(@FHTMP@(FHI)) Q:FHI'>0 D CLIN I ANS="^" K ^TMP($J) Q
- K ^TMP($J)
- ;end changes in patch #41
- Q:ANS="^"
- NOAPP I 'N1 W !!?5,"No scheduled appointments."
- D FOOT^FHASP Q
- LST S X0=$G(^FHEN(ASN,0)) Q:$P(X0,"^",4)<3
- S X1=$G(^FHEN(ASN,"P",DFN,0))
- W:'N1 ! S N1=N1+1,DTP=$P(X0,"^",2) D DTP^FH W !?5,$E(DTP,1,9)," " S Y=$P(X0,"^",4),Y=$P($G(^FH(115.6,+Y,0)),"^",1) W Y I $P(X0,"^",7)="F" W " (FU)"
- S Y=$P(X0,"^",9) W ", ",$S(Y="G":"Group",1:"Individual")
- S Y=$P(X0,"^",11) W:Y'="" !?10,Y S Y=$P(X1,"^",4) W:Y'="" !?10,Y Q
- ;patch #41
- CLIN ;S SC=+$P(Z,"^",1),Y=$P($G(^SC(SC,0)),"^",1) Q:Y=""
- S NDT=@FHTMP@(FHI,1)
- S SC=$P(@FHTMP@(FHI,2),U,1)
- S Y=$P(@FHTMP@(FHI,2),U,2) Q:Y=""
- D:$Y'<S1 HF^FHASP Q:ANS="^" W:'N1 ! S N1=N1+1,DTP=NDT D DTP^FH W !?5,DTP,?25,Y Q
- ;D:$Y'<S1 HF^FHASP Q:ANS="^" W:'N1 ! S N1=N1+1,DTP=NDT D DTP^FH W !?5,DTP,?25,Y W:$P(Z,"^",11) " (Collateral)" Q
- ;end changes in patch #41
- DISP ; Display Food Preferences
- W !?26,"Likes",?58,"DisLikes",!
- K P S P1=1 F K=0:0 S K=$O(^FHPT(FHDFN,"P",K)) Q:K<1 S X=^(K,0) D SP
- W ! S (M,MM)="" F S M=$O(P(M)) Q:M="" I $D(P(M)) W $P(M,"~",2) D S MM=M
- . S (P1,P2)=0 F S:P1'="" P1=$O(P(M,"L",P1)) S X1=$S(P1>0:P(M,"L",P1),1:"") S:P2'="" P2=$O(P(M,"D",P2)) S X2=$S(P2>0:P(M,"D",P2),1:"") Q:P1=""&(P2="") D P0 Q:ANS="^" W:MM'=M !
- . Q
- Q:ANS="^"
- I $O(P(""))="" W !,"No Food Preferences on file",!
- Q
- P0 I X1'="" W ?12 S X=X1 D P1 S X1=X
- I X2'="" W ?46 S X=X2 D P1 S X2=X
- Q:X1=""&(X2="") D:$Y'<S1 HF^FHASP Q:ANS="^" W ! G P0
- P1 I $L(X)<34 W X S X="" Q
- F KK=35:-1:1 Q:$E(X,KK-1,KK)=", "
- W $E(X,1,KK-2) S X=$E(X,KK+1,999) Q
- SP Q:'$P(X,U) S M1=$P(X,"^",2) S:M1="A"!(M1="") M1="BNE" S Z=$G(^FH(115.2,+X,0)) Q:$P(Z,U)=""!($P(Z,U,2)="") S L1=$P(Z,"^",1),KK=$P(Z,"^",2),M="",DAS=$P(X,"^",4)
- I KK="L" S Q=$P(X,"^",3),L1=$S(Q:Q,1:1)_" "_L1
- I M1="BNE" S M="1~All Meals" G SP1
- S Z1=$E(M1,1) I Z1'="" S M=$S(Z1="B":"2~Break",Z1="N":"3~Noon",1:"4~Even")
- S Z1=$E(M1,2) I Z1'="" S M=M_","_$S(Z1="B":"Break",Z1="N":"Noon",1:"Even")
- SP1 S:'$D(P(M,KK,P1)) P(M,KK,P1)="" I $L(P(M,KK,P1))+$L(L1)<255 S P(M,KK,P1)=P(M,KK,P1)_$S(P(M,KK,P1)="":"",1:", ")_L1_$S(DAS="Y":" (D)",1:"")
- E S:'$D(P(M,KK,K)) P(M,KK,K)="" S P(M,KK,K)=L1_$S(DAS="Y":" (D)",1:"") S P1=K
- Q
- MO ; Display Monitors
- S Y=$G(^FHPT(FHDFN,"A",FADM,"MO",K,0)) Q:Y="" S N1=N1+1
- D:$Y'<S1 HF^FHASP Q:ANS="^"
- W !,$P(Y,"^",1) S DTP=$P(Y,"^",2) D DTP^FH W ", ",DTP
- S COM=$P(Y,"^",3) W:COM'="" !?5,"Action: ",COM Q
- PRERR ;if Scheduling API returns an error, print error in the report.
- S FHER=$O(@FHTMP@("ERROR",0))
- W !!,"*** ERROR in Scheduling API ***"
- W !,"***",@FHTMP@("ERROR",FHER)," !!!",!
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHASP1 4330 printed Mar 13, 2025@20:51:49 Page 2
- FHASP1 ; HISC/REL/JH - Nutrition Profile (cont) ;5/2/01 10:14
- +1 ;;5.5;DIETETICS;**8,9**;Jan 28, 2005;Build 7
- +2 ;
- +3 IF '$GET(FHET)
- SET X="T-365"
- SET %DT="XT"
- DO ^%DT
- SET FHET=Y
- KILL %DT
- +4 SET DTP=FHET
- DO DTP^FH
- SET FHENDATE=DTP
- +5 SET N1=0
- +6 WRITE !!?22,"Dietetic Encounters since ",FHENDATE
- +7 FOR FHET=FHET:0
- SET FHET=$ORDER(^FHEN("AP",DFN,FHET))
- if FHET<1!(ANS="^")
- QUIT
- FOR ASN=0:0
- SET ASN=$ORDER(^FHEN("AP",DFN,FHET,ASN))
- if ASN<1
- QUIT
- if $Y'<S1
- DO HF^FHASP
- if ANS="^"
- QUIT
- DO LST
- +8 if ANS="^"
- QUIT
- +9 IF 'N1
- WRITE !!?5,"No Encounters recorded since ",FHENDATE
- +10 SET FHZ115="P"_DFN
- DO CHECK^FHOMDPA
- IF FHDFN=""
- QUIT
- +11 SET FADM=$ORDER(^FHPT(FHDFN,"A",""),-1)
- SET FADM=$SELECT($GET(ADM):$GET(ADM),FADM:FADM,1:"")
- if FADM=""
- GOTO F1
- +12 if $Y'<(S1-6)
- DO HF^FHASP
- if ANS="^"
- QUIT
- WRITE !!?28,$SELECT($GET(ADM):"Current",1:"Last")," Admission Monitors"
- SET N1=0
- +13 ; F NDT=0:0 S NDT=$O(^FHPT(FHDFN,"A",FADM,"MO","AC",NDT)) Q:NDT<1 F K=0:0 S K=$O(^FHPT(FHDFN,"A",FADM,"MO","AC",NDT,K)) Q:K<1 D MO
- +14 SET FHTTLM=""
- SET FHTTLM=$PIECE($GET(^FHPT(FHDFN,"A",FADM,"MO",0)),U,3)
- +15 IF FHTTLM=""
- WRITE !,"No Monitors on file."
- GOTO F1
- +16 SET FHMONS=$SELECT(FHTTLM-FHNUM<0:0,1:FHTTLM-FHNUM)
- +17 FOR NDT=FHMONS:0
- SET NDT=$ORDER(^FHPT(FHDFN,"A",FADM,"MO",NDT))
- if NDT<1!(ANS="^")
- QUIT
- SET K=NDT
- DO MO
- +18 if ANS="^"
- QUIT
- IF 'N1
- WRITE !,"No Monitors on file."
- F1 if $Y'<(S1-6)
- DO HF^FHASP
- if ANS="^"
- QUIT
- WRITE !!?32,"Food Preferences"
- DO DISP
- +1 WRITE !!?27,"Future Clinic Appointments"
- SET N1=0
- +2 ;
- +3 ;patch #41
- +4 ;F NDT=NOW:0 S NDT=$O(^DPT(DFN,"S",NDT)) Q:NDT'>0 S Z=^(NDT,0) I "I"[$P(Z,"^",2) D CLIN Q:ANS="^"
- +5 KILL ^TMP($JOB)
- +6 SET FHCNT=""
- +7 DO GETAPPT^SDAMA201(DFN,"1;2;12","R",DT,,.FHCNT,"")
- +8 if '$DATA(^TMP($JOB,"SDAMA201","GETAPPT"))
- GOTO NOAPP
- +9 IF $DATA(^TMP($JOB,"SDAMA201","GETAPPT"))
- SET FHTMP=$NAME(^TMP($JOB,"SDAMA201","GETAPPT"))
- +10 IF $DATA(@FHTMP@("ERROR"))
- DO PRERR
- +11 IF $GET(FHCNT)
- FOR FHI=0:0
- SET FHI=$ORDER(@FHTMP@(FHI))
- if FHI'>0
- QUIT
- DO CLIN
- IF ANS="^"
- KILL ^TMP($JOB)
- QUIT
- +12 KILL ^TMP($JOB)
- +13 ;end changes in patch #41
- +14 if ANS="^"
- QUIT
- NOAPP IF 'N1
- WRITE !!?5,"No scheduled appointments."
- +1 DO FOOT^FHASP
- QUIT
- LST SET X0=$GET(^FHEN(ASN,0))
- if $PIECE(X0,"^",4)<3
- QUIT
- +1 SET X1=$GET(^FHEN(ASN,"P",DFN,0))
- +2 if 'N1
- WRITE !
- SET N1=N1+1
- SET DTP=$PIECE(X0,"^",2)
- DO DTP^FH
- WRITE !?5,$EXTRACT(DTP,1,9)," "
- SET Y=$PIECE(X0,"^",4)
- SET Y=$PIECE($GET(^FH(115.6,+Y,0)),"^",1)
- WRITE Y
- IF $PIECE(X0,"^",7)="F"
- WRITE " (FU)"
- +3 SET Y=$PIECE(X0,"^",9)
- WRITE ", ",$SELECT(Y="G":"Group",1:"Individual")
- +4 SET Y=$PIECE(X0,"^",11)
- if Y'=""
- WRITE !?10,Y
- SET Y=$PIECE(X1,"^",4)
- if Y'=""
- WRITE !?10,Y
- QUIT
- +5 ;patch #41
- CLIN ;S SC=+$P(Z,"^",1),Y=$P($G(^SC(SC,0)),"^",1) Q:Y=""
- +1 SET NDT=@FHTMP@(FHI,1)
- +2 SET SC=$PIECE(@FHTMP@(FHI,2),U,1)
- +3 SET Y=$PIECE(@FHTMP@(FHI,2),U,2)
- if Y=""
- QUIT
- +4 if $Y'<S1
- DO HF^FHASP
- if ANS="^"
- QUIT
- if 'N1
- WRITE !
- SET N1=N1+1
- SET DTP=NDT
- DO DTP^FH
- WRITE !?5,DTP,?25,Y
- QUIT
- +5 ;D:$Y'<S1 HF^FHASP Q:ANS="^" W:'N1 ! S N1=N1+1,DTP=NDT D DTP^FH W !?5,DTP,?25,Y W:$P(Z,"^",11) " (Collateral)" Q
- +6 ;end changes in patch #41
- DISP ; Display Food Preferences
- +1 WRITE !?26,"Likes",?58,"DisLikes",!
- +2 KILL P
- SET P1=1
- FOR K=0:0
- SET K=$ORDER(^FHPT(FHDFN,"P",K))
- if K<1
- QUIT
- SET X=^(K,0)
- DO SP
- +3 WRITE !
- SET (M,MM)=""
- FOR
- SET M=$ORDER(P(M))
- if M=""
- QUIT
- IF $DATA(P(M))
- WRITE $PIECE(M,"~",2)
- Begin DoDot:1
- +4 SET (P1,P2)=0
- FOR
- if P1'=""
- SET P1=$ORDER(P(M,"L",P1))
- SET X1=$SELECT(P1>0:P(M,"L",P1),1:"")
- if P2'=""
- SET P2=$ORDER(P(M,"D",P2))
- SET X2=$SELECT(P2>0:P(M,"D",P2),1:"")
- if P1=""&(P2="")
- QUIT
- DO P0
- if ANS="^"
- QUIT
- if MM'=M
- WRITE !
- +5 QUIT
- End DoDot:1
- SET MM=M
- +6 if ANS="^"
- QUIT
- +7 IF $ORDER(P(""))=""
- WRITE !,"No Food Preferences on file",!
- +8 QUIT
- P0 IF X1'=""
- WRITE ?12
- SET X=X1
- DO P1
- SET X1=X
- +1 IF X2'=""
- WRITE ?46
- SET X=X2
- DO P1
- SET X2=X
- +2 if X1=""&(X2="")
- QUIT
- if $Y'<S1
- DO HF^FHASP
- if ANS="^"
- QUIT
- WRITE !
- GOTO P0
- P1 IF $LENGTH(X)<34
- WRITE X
- SET X=""
- QUIT
- +1 FOR KK=35:-1:1
- if $EXTRACT(X,KK-1,KK)=", "
- QUIT
- +2 WRITE $EXTRACT(X,1,KK-2)
- SET X=$EXTRACT(X,KK+1,999)
- QUIT
- SP if '$PIECE(X,U)
- QUIT
- SET M1=$PIECE(X,"^",2)
- if M1="A"!(M1="")
- SET M1="BNE"
- SET Z=$GET(^FH(115.2,+X,0))
- if $PIECE(Z,U)=""!($PIECE(Z,U,2)="")
- QUIT
- SET L1=$PIECE(Z,"^",1)
- SET KK=$PIECE(Z,"^",2)
- SET M=""
- SET DAS=$PIECE(X,"^",4)
- +1 IF KK="L"
- SET Q=$PIECE(X,"^",3)
- SET L1=$SELECT(Q:Q,1:1)_" "_L1
- +2 IF M1="BNE"
- SET M="1~All Meals"
- GOTO SP1
- +3 SET Z1=$EXTRACT(M1,1)
- IF Z1'=""
- SET M=$SELECT(Z1="B":"2~Break",Z1="N":"3~Noon",1:"4~Even")
- +4 SET Z1=$EXTRACT(M1,2)
- IF Z1'=""
- SET M=M_","_$SELECT(Z1="B":"Break",Z1="N":"Noon",1:"Even")
- SP1 if '$DATA(P(M,KK,P1))
- SET P(M,KK,P1)=""
- IF $LENGTH(P(M,KK,P1))+$LENGTH(L1)<255
- SET P(M,KK,P1)=P(M,KK,P1)_$SELECT(P(M,KK,P1)="":"",1:", ")_L1_$SELECT(DAS="Y":" (D)",1:"")
- +1 IF '$TEST
- if '$DATA(P(M,KK,K))
- SET P(M,KK,K)=""
- SET P(M,KK,K)=L1_$SELECT(DAS="Y":" (D)",1:"")
- SET P1=K
- +2 QUIT
- MO ; Display Monitors
- +1 SET Y=$GET(^FHPT(FHDFN,"A",FADM,"MO",K,0))
- if Y=""
- QUIT
- SET N1=N1+1
- +2 if $Y'<S1
- DO HF^FHASP
- if ANS="^"
- QUIT
- +3 WRITE !,$PIECE(Y,"^",1)
- SET DTP=$PIECE(Y,"^",2)
- DO DTP^FH
- WRITE ", ",DTP
- +4 SET COM=$PIECE(Y,"^",3)
- if COM'=""
- WRITE !?5,"Action: ",COM
- QUIT
- PRERR ;if Scheduling API returns an error, print error in the report.
- +1 SET FHER=$ORDER(@FHTMP@("ERROR",0))
- +2 WRITE !!,"*** ERROR in Scheduling API ***"
- +3 WRITE !,"***",@FHTMP@("ERROR",FHER)," !!!",!
- +4 QUIT
