- FHADR6 ; HISC/NCA - Modified Diet Percentage ;1/23/98 16:06
- ;;5.5;DIETETICS;;Jan 28, 2005
- EN1 ; Enter Snapshot Date
- S (MD,N)=0 D QR^FHADR1 G:'PRE KIL
- S (ANS,XX)="",TIM=$P($G(^FH(117.3,PRE,1)),"^",12) I TIM'="" S Y=TIM X ^DD("DD") S XX=Y
- F1 K %DT W !,"Select SUNDAY Date: ",$S(XX'="":XX_"// ",1:"") R X:DTIME G:'$T!(X["^") KIL
- S:X="" X=XX
- S %DT="EXP" D ^%DT G KIL:$D(DTOUT),F1:Y<1
- S (TIM,X)=Y D H^%DTC G:%Y<0 F1 I %Y W *7," .. Not a Sunday" G F1
- S TS=$E(TIM,4,5),TS=$S(TS<4:2,TS<7:3,TS<10:4,1:1) I TS'=$E(PRE,5) W *7," .. Date Not Within Qtr" G F1
- I TS>1,$E(PRE,1,3)'=$E(TIM,1,3) W *7,"..Date Not Within Qtr" G F1
- I TS=1,$E(PRE,1,3)-1'=$E(TIM,1,3) W *7,"..Date Not Within Qtr" G F1
- S $P(^FH(117.3,PRE,1),"^",12)=TIM\1
- DISP ; Display the numbers of the seven days for validation
- K DC,M,TM S D1=TIM\1 F L=1:1:7 S DC(L)=D1,X1=D1,X2=1 D C^%DTC S D1=X
- F K=1:1:7 S R=$G(^FH(117,DC(K),1)),N=$P(R,"^",26,27) D
- .S M(K)=$P(N,"^",1)
- .I '$P(N,"^",2) D
- ..F LP=21:1:25 S $P(N,"^",2)=$P(N,"^",2)+$P(R,"^",LP)
- ..S $P(^FH(117,DC(K),1),"^",27)=$P(N,"^",2)
- ..Q
- .S TM(K)=$P(N,"^",2)
- .Q
- ; Display Data for the seven dates
- W !!?25 S Y=DC(1) X ^DD("DD") W Y," - " S Y=DC(7) X ^DD("DD") W Y
- W !!?12,"| X | M | T | W | R | F | S |"
- W !?12,"| Sun | Mon | Tues | Wed | Thur | Fri | Sat | Total"
- W !,"_____________________________________________________________________________"
- W !,"# Mod. Diets" S TOT=0 F L=1:1:7 W "|",$J($S(M(L):M(L),1:""),7) S TOT=TOT+M(L)
- W "|",$J($S(TOT:TOT,1:""),8) S TOT=0
- W !,"Total Diets",?12 F L=1:1:7 W "|",$J($S(TM(L):TM(L),1:""),7) S TOT=TOT+TM(L)
- W "|",$J($S(TOT:TOT,1:""),8)
- F2 R !!,"Change Numbers of Modified Diets and Total Diets for that week? Y// ",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 F2
- S X=$E(X,1) G:X="N" KIL
- OK W !!?10,"Sun Mon Tues Wed Thur Fri Sat"
- W !?10," X M T W R F S"
- W !!,"Enter string of characters for desired days of week: e.g., MWF",!
- OK1 R !!,"Select the Day of Week you wish to change the data on: ",WKDS:DTIME G:'$T!("^"[WKDS) KIL S X=WKDS D TR^FH S WKDS=X
- S X1="" F K=1:1 S Z=$E(WKDS,K) Q:Z="" G:X1[Z MSG S X1=X1_Z I "XMTWRFS"'[Z W !,"Please enter the desired days of the week." G OK
- F K=1:1 S Y=$E(WKDS,K) Q:Y="" S DAY=$F("XMTWRFS",Y),DAY=DAY-1,WK=$P("Sun Mon Tues Wed Thur Fri Sat"," ",DAY) D E1 Q:ANS="^"
- G KIL:ANS="^",DISP
- E1 W !!,"Change # of Modified Diets for ",WK," from ",$S(M(DAY):M(DAY),1:"")," to: " R Y:DTIME I '$T!(Y["^") S ANS="^" Q
- I Y="",M(DAY) S Y=M(DAY) W " ",M(DAY)
- I Y'?1N.N!(Y'>0)!(Y>999999999) W *7,!," Enter an amount greater than 0 but less than 999999999" G E1
- S M(DAY)=Y
- E2 W !!,"Change # of Total Diets for ",WK," from ",$S(TM(DAY):TM(DAY),1:"")," to: " R Y:DTIME I '$T!(Y["^") S ANS="^" Q
- I Y="",TM(DAY) S Y=TM(DAY) W " ",TM(DAY)
- I Y'?1N.N!(Y'>0)!(Y>9999999999) W *7,!," Enter an amount greater than 0 but less than 9999999999" G E2
- S TM(DAY)=Y
- S $P(^FH(117,DC(DAY),1),"^",26,27)=M(DAY)_"^"_TM(DAY)
- Q
- MSG W *7,!," Error - Illegal Character or Repeated Day." G OK1
- KIL G KILL^XUSCLEAN
- EN2 ; Print the % Modified Diet and Number of Patients
- K M,N,TD,TM S (TOT,TQ)=0 F K=1:1:4 S (M(K),TD(K),TM(K))=""
- D:$Y'<(LIN-7) HDR^FHADRPT,HDR2^FHADR3A
- W !!!!,"MODIFIED DIET SUMMARY"
- W !!?35,"1st Qtr",?55,"2nd Qtr",?75,"3rd Qtr",?95,"4th Qtr",?115,"YTD Avg",!
- P1 ; Build List of dates and add the Modified Diets for the seven days
- F QR=1:1:4 S QTR=QR,PRE=FHYR_"0"_QTR_"00" D
- .S TIM=$P($G(^FH(117.3,PRE,1)),"^",12) Q:'TIM
- .K DC S D1=TIM\1 F L=1:1:7 S DC(L)=D1,X1=D1,X2=1 D C^%DTC S D1=X
- .F K=1:1:7 S R=$G(^FH(117,DC(K),1)),N=$P(R,"^",26,27) I N'="" D
- ..Q:'$P(N,"^",1) S M(QTR)=M(QTR)+$P(N,"^",1)
- ..I '$P(N,"^",2) D
- ...F LP=21:1:25 S $P(N,"^",2)=$P(N,"^",2)+$P(R,"^",LP)
- ...S $P(^FH(117,DC(K),1),"^",27)=$P(N,"^",2)
- ...Q
- ..Q:'$P(N,"^",2) S TM(QTR)=TM(QTR)+$P(N,"^",2)
- ..S TD(QTR)=TD(QTR)+1
- ..Q
- .S:TD(QTR)'="" TQ=TQ+1
- .Q
- W !,"Week Average Modified Diet",?35 F QTR=1:1:4 S X=$S(+TM(QTR)'<1:M(QTR)/TM(QTR)*100,1:""),TOT=TOT+X W $S(X:$J(X,7,1),1:$J("",7))_$J("",13)
- W $S(TQ:$J(TOT/TQ,7,1),1:$J("",7))
- K LP,M,N,R,TD,TM Q
- FHADR6 ; HISC/NCA - Modified Diet Percentage ;1/23/98 16:06
- +1 ;;5.5;DIETETICS;;Jan 28, 2005
- EN1 ; Enter Snapshot Date
- +1 SET (MD,N)=0
- DO QR^FHADR1
- IF 'PRE
- GOTO KIL
- +2 SET (ANS,XX)=""
- SET TIM=$PIECE($GET(^FH(117.3,PRE,1)),"^",12)
- IF TIM'=""
- SET Y=TIM
- XECUTE ^DD("DD")
- SET XX=Y
- F1 KILL %DT
- WRITE !,"Select SUNDAY Date: ",$SELECT(XX'="":XX_"// ",1:"")
- READ X:DTIME
- IF '$TEST!(X["^")
- GOTO KIL
- +1 IF X=""
- SET X=XX
- +2 SET %DT="EXP"
- DO ^%DT
- IF $DATA(DTOUT)
- GOTO KIL
- IF Y<1
- GOTO F1
- +3 SET (TIM,X)=Y
- DO H^%DTC
- IF %Y<0
- GOTO F1
- IF %Y
- WRITE *7," .. Not a Sunday"
- GOTO F1
- +4 SET TS=$EXTRACT(TIM,4,5)
- SET TS=$SELECT(TS<4:2,TS<7:3,TS<10:4,1:1)
- IF TS'=$EXTRACT(PRE,5)
- WRITE *7," .. Date Not Within Qtr"
- GOTO F1
- +5 IF TS>1
- IF $EXTRACT(PRE,1,3)'=$EXTRACT(TIM,1,3)
- WRITE *7,"..Date Not Within Qtr"
- GOTO F1
- +6 IF TS=1
- IF $EXTRACT(PRE,1,3)-1'=$EXTRACT(TIM,1,3)
- WRITE *7,"..Date Not Within Qtr"
- GOTO F1
- +7 SET $PIECE(^FH(117.3,PRE,1),"^",12)=TIM\1
- DISP ; Display the numbers of the seven days for validation
- +1 KILL DC,M,TM
- SET D1=TIM\1
- FOR L=1:1:7
- SET DC(L)=D1
- SET X1=D1
- SET X2=1
- DO C^%DTC
- SET D1=X
- +2 FOR K=1:1:7
- SET R=$GET(^FH(117,DC(K),1))
- SET N=$PIECE(R,"^",26,27)
- Begin DoDot:1
- +3 SET M(K)=$PIECE(N,"^",1)
- +4 IF '$PIECE(N,"^",2)
- Begin DoDot:2
- +5 FOR LP=21:1:25
- SET $PIECE(N,"^",2)=$PIECE(N,"^",2)+$PIECE(R,"^",LP)
- +6 SET $PIECE(^FH(117,DC(K),1),"^",27)=$PIECE(N,"^",2)
- +7 QUIT
- End DoDot:2
- +8 SET TM(K)=$PIECE(N,"^",2)
- +9 QUIT
- End DoDot:1
- +10 ; Display Data for the seven dates
- +11 WRITE !!?25
- SET Y=DC(1)
- XECUTE ^DD("DD")
- WRITE Y," - "
- SET Y=DC(7)
- XECUTE ^DD("DD")
- WRITE Y
- +12 WRITE !!?12,"| X | M | T | W | R | F | S |"
- +13 WRITE !?12,"| Sun | Mon | Tues | Wed | Thur | Fri | Sat | Total"
- +14 WRITE !,"_____________________________________________________________________________"
- +15 WRITE !,"# Mod. Diets"
- SET TOT=0
- FOR L=1:1:7
- WRITE "|",$JUSTIFY($SELECT(M(L):M(L),1:""),7)
- SET TOT=TOT+M(L)
- +16 WRITE "|",$JUSTIFY($SELECT(TOT:TOT,1:""),8)
- SET TOT=0
- +17 WRITE !,"Total Diets",?12
- FOR L=1:1:7
- WRITE "|",$JUSTIFY($SELECT(TM(L):TM(L),1:""),7)
- SET TOT=TOT+TM(L)
- +18 WRITE "|",$JUSTIFY($SELECT(TOT:TOT,1:""),8)
- F2 READ !!,"Change Numbers of Modified Diets and Total Diets for that week? Y// ",X:DTIME
- IF '$TEST!(X="^")
- GOTO KIL
- 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 F2
- +1 SET X=$EXTRACT(X,1)
- IF X="N"
- GOTO KIL
- OK WRITE !!?10,"Sun Mon Tues Wed Thur Fri Sat"
- +1 WRITE !?10," X M T W R F S"
- +2 WRITE !!,"Enter string of characters for desired days of week: e.g., MWF",!
- OK1 READ !!,"Select the Day of Week you wish to change the data on: ",WKDS:DTIME
- IF '$TEST!("^"[WKDS)
- GOTO KIL
- SET X=WKDS
- DO TR^FH
- SET WKDS=X
- +1 SET X1=""
- FOR K=1:1
- SET Z=$EXTRACT(WKDS,K)
- IF Z=""
- QUIT
- IF X1[Z
- GOTO MSG
- SET X1=X1_Z
- IF "XMTWRFS"'[Z
- WRITE !,"Please enter the desired days of the week."
- GOTO OK
- +2 FOR K=1:1
- SET Y=$EXTRACT(WKDS,K)
- IF Y=""
- QUIT
- SET DAY=$FIND("XMTWRFS",Y)
- SET DAY=DAY-1
- SET WK=$PIECE("Sun Mon Tues Wed Thur Fri Sat"," ",DAY)
- DO E1
- IF ANS="^"
- QUIT
- +3 IF ANS="^"
- GOTO KIL
- GOTO DISP
- E1 WRITE !!,"Change # of Modified Diets for ",WK," from ",$SELECT(M(DAY):M(DAY),1:"")," to: "
- READ Y:DTIME
- IF '$TEST!(Y["^")
- SET ANS="^"
- QUIT
- +1 IF Y=""
- IF M(DAY)
- SET Y=M(DAY)
- WRITE " ",M(DAY)
- +2 IF Y'?1N.N!(Y'>0)!(Y>999999999)
- WRITE *7,!," Enter an amount greater than 0 but less than 999999999"
- GOTO E1
- +3 SET M(DAY)=Y
- E2 WRITE !!,"Change # of Total Diets for ",WK," from ",$SELECT(TM(DAY):TM(DAY),1:"")," to: "
- READ Y:DTIME
- IF '$TEST!(Y["^")
- SET ANS="^"
- QUIT
- +1 IF Y=""
- IF TM(DAY)
- SET Y=TM(DAY)
- WRITE " ",TM(DAY)
- +2 IF Y'?1N.N!(Y'>0)!(Y>9999999999)
- WRITE *7,!," Enter an amount greater than 0 but less than 9999999999"
- GOTO E2
- +3 SET TM(DAY)=Y
- +4 SET $PIECE(^FH(117,DC(DAY),1),"^",26,27)=M(DAY)_"^"_TM(DAY)
- +5 QUIT
- MSG WRITE *7,!," Error - Illegal Character or Repeated Day."
- GOTO OK1
- KIL GOTO KILL^XUSCLEAN
- EN2 ; Print the % Modified Diet and Number of Patients
- +1 KILL M,N,TD,TM
- SET (TOT,TQ)=0
- FOR K=1:1:4
- SET (M(K),TD(K),TM(K))=""
- +2 IF $Y'<(LIN-7)
- DO HDR^FHADRPT
- DO HDR2^FHADR3A
- +3 WRITE !!!!,"MODIFIED DIET SUMMARY"
- +4 WRITE !!?35,"1st Qtr",?55,"2nd Qtr",?75,"3rd Qtr",?95,"4th Qtr",?115,"YTD Avg",!
- P1 ; Build List of dates and add the Modified Diets for the seven days
- +1 FOR QR=1:1:4
- SET QTR=QR
- SET PRE=FHYR_"0"_QTR_"00"
- Begin DoDot:1
- +2 SET TIM=$PIECE($GET(^FH(117.3,PRE,1)),"^",12)
- IF 'TIM
- QUIT
- +3 KILL DC
- SET D1=TIM\1
- FOR L=1:1:7
- SET DC(L)=D1
- SET X1=D1
- SET X2=1
- DO C^%DTC
- SET D1=X
- +4 FOR K=1:1:7
- SET R=$GET(^FH(117,DC(K),1))
- SET N=$PIECE(R,"^",26,27)
- IF N'=""
- Begin DoDot:2
- +5 IF '$PIECE(N,"^",1)
- QUIT
- SET M(QTR)=M(QTR)+$PIECE(N,"^",1)
- +6 IF '$PIECE(N,"^",2)
- Begin DoDot:3
- +7 FOR LP=21:1:25
- SET $PIECE(N,"^",2)=$PIECE(N,"^",2)+$PIECE(R,"^",LP)
- +8 SET $PIECE(^FH(117,DC(K),1),"^",27)=$PIECE(N,"^",2)
- +9 QUIT
- End DoDot:3
- +10 IF '$PIECE(N,"^",2)
- QUIT
- SET TM(QTR)=TM(QTR)+$PIECE(N,"^",2)
- +11 SET TD(QTR)=TD(QTR)+1
- +12 QUIT
- End DoDot:2
- +13 IF TD(QTR)'=""
- SET TQ=TQ+1
- +14 QUIT
- End DoDot:1
- +15 WRITE !,"Week Average Modified Diet",?35
- FOR QTR=1:1:4
- SET X=$SELECT(+TM(QTR)'<1:M(QTR)/TM(QTR)*100,1:"")
- SET TOT=TOT+X
- WRITE $SELECT(X:$JUSTIFY(X,7,1),1:$JUSTIFY("",7))_$JUSTIFY("",13)
- +16 WRITE $SELECT(TQ:$JUSTIFY(TOT/TQ,7,1),1:$JUSTIFY("",7))
- +17 KILL LP,M,N,R,TD,TM
- QUIT
