- FHORT5A ; HISC/REL/NCA/RVD - Tubefeeding Reports (cont) ;3/1/04 13:15
- ;;5.5;DIETETICS;**1,3,5**;Jan 28, 2005;Build 53
- ;
- Q1 ; Print Tubefeeding Report
- S PG=0 D NOW^%DTC S (DTP,NOW)=% D DTP^FH K ^TMP($J)
- INPAT ;get inpatient data
- F FHDFN=0:0 S FHDFN=$O(^FHPT("ADTF",FHDFN)) Q:FHDFN<1 F ADM=0:0 S ADM=$O(^FHPT("ADTF",FHDFN,ADM)) Q:ADM<1 D PATNAME^FHOMUTL Q:DFN="" D Q2
- ;
- OUTPAT ;get outpatient data, for today's date.
- F FHDFN=0:0 S FHDFN=$O(^FHPT("RM",DT,FHDFN)) Q:FHDFN'>0 F FHFIN=0:0 S FHFIN=$O(^FHPT("RM",DT,FHDFN,FHFIN)) Q:FHFIN'>0 D
- .;quit if TF is cancelled
- .I $D(^FHPT(FHDFN,"OP",FHFIN,3)),$P(^(3),U,5)="C" Q
- .S (FHRMB,RM)=" "
- .I $D(^FHPT(FHDFN,"OP",FHFIN,0)) S FHRMB=$P($G(^FHPT(FHDFN,"OP",FHFIN,0)),U,18)
- .I $G(FHRMB),$D(^DG(405.4,FHRMB,0)) S RM=$P(^DG(405.4,FHRMB,0),U,1)
- .F FHTF=0:0 S FHTF=$O(^FHPT(FHDFN,"OP",FHFIN,"TF",FHTF)) Q:FHTF'>0 D
- ..Q:'$D(^FHPT(FHDFN,"OP",FHFIN,"TF",FHTF,0))
- ..S YY=$G(^FHPT(FHDFN,"OP",FHFIN,"TF",FHTF,0))
- ..;
- ..S TF2=FHTF
- ..S Z=$G(^FHPT(FHDFN,"OP",FHFIN,0))
- ..S XY=$G(^FHPT(FHDFN,"OP",FHFIN,3))
- ..S (Z1,Z2)="",W1=$P(Z,"^",3)
- ..S P0=$G(^FH(119.6,+W1,0)),Z3=$P(P0,"^",8),WARD=$E($P(P0,"^",1),U,12)
- ..S CC=$P($G(^FH(119.73,+Z3,0)),"^",1)
- ..I FHXX="C" S D2=$P(P0,"^",8) I FHP,FHP'=D2 Q
- ..I FHXX="L" I FHP,FHP'=W1 Q
- ..S P0=$P(P0,"^",4),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0)
- ..S TNOD=$S(FHXX="C":"99~"_CC,1:P0_"~"_WARD),CNOD=$S('SUM:TNOD,1:"0")
- ..;
- ..I FHOPT=3 D
- ...S CTR=$G(^TMP($J,"C",CNOD,0))
- ...;I "^^^^"[FHOR S:Z2 $P(CTR,"^",1)=$P(CTR,"^",1)+1 S:Z2 $P(CTR,"^",3)=$P(CTR,"^",3)+1
- ...S $P(CTR,"^",1)=$P(CTR,"^",1)+1
- ...;I "^^^^"'[FHOR,Z1="T" S:'Z2 $P(CTR,"^",2)=$P(CTR,"^",2)+1 S:Z2 $P(CTR,"^",4)=$P(CTR,"^",4)+1
- ...S ^TMP($J,"C",CNOD,0)=CTR Q
- ..;
- ..S TP=$P(YY,"^",4) D PREP
- ..;set ^tmp global for specific report.
- ..D PATNAME^FHOMUTL
- ..S PNOD=P0_"~"_WARD_"~"_FHDFN
- ..I "135"[FHOPT S:'$D(^TMP($J,"C",CNOD,TUN,0)) ^(0)="" S $P(^(0),"^",1)=$P(^(0),"^",1)+TU,$P(^(0),"^",2)=$P(^(0),"^",2)+1
- ..I "124"[FHOPT D
- ...S:'$D(^TMP($J,"T",TNOD,PNOD,0)) ^(0)=$E(FHPTNM,1,22)_"^"_FHBID_"^"_WARD_"^"_RM_"^"_$P(XY,"^",1,3)
- ...S ^TMP($J,"T",TNOD,PNOD,TF2,0)=$P(Y0,"^",1)_"^"_$P(Y0,"^",2)_"^"_TP_"^"_TW_"^"_TU_"^"_P1_"^"_STR_"^"_QUA_"^"_TUN
- ;
- PRT ;prints corresponding reports.
- I FHOPT=1 D PREP^FHORT5B,PULL^FHORT5C,DEL^FHORT5C Q
- I FHOPT=2 D PREP^FHORT5B Q
- I FHOPT=3 D CST^FHORT5D Q
- I FHOPT=4 D LAB^FHORT5D Q
- I FHOPT=5 D PULL^FHORT5C
- Q
- Q2 S Z=$G(^FHPT(FHDFN,"A",ADM,0)),WARD=$P(Z,"^",8) S:WARD WARD=$P($G(^FH(119.6,WARD,0)),"^",1) I WARD="" G Q3
- G:'$D(^DPT(DFN,.1)) Q3 S CADM=$G(^DPT("CN",^DPT(DFN,.1),DFN)) G:ADM'=CADM Q3
- S TF=$P(Z,"^",4) G:TF<1 Q3
- S Z1=$P(Z,"^",5),Z2=$P(Z,"^",7),W1=$P(Z,"^",8),P0=$G(^FH(119.6,+W1,0)),Z3=$P(P0,"^",8),CC=$P($G(^FH(119.73,+Z3,0)),"^",1)
- I FHXX="C" S D2=$P(P0,"^",8) I FHP,FHP'=D2 Q
- I FHXX="L" I FHP,FHP'=W1 Q
- S P0=$P(P0,"^",4),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0)
- S TNOD=$S(FHXX="C":"99~"_CC,1:P0_"~"_WARD),CNOD=$S('SUM:TNOD,1:"0")
- D CUR^FHORD7 I FHLD="P" Q
- I FHOPT=3 D
- .S CTR=$G(^TMP($J,"C",CNOD,0))
- .I "^^^^"[FHOR S:'Z2 $P(CTR,"^",1)=$P(CTR,"^",1)+1 S:Z2 $P(CTR,"^",3)=$P(CTR,"^",3)+1
- .I "^^^^"'[FHOR,Z1="T" S:'Z2 $P(CTR,"^",2)=$P(CTR,"^",2)+1 S:Z2 $P(CTR,"^",4)=$P(CTR,"^",4)+1
- .S ^TMP($J,"C",CNOD,0)=CTR Q
- I "124"[FHOPT D
- .S RM=$G(^DPT(DFN,.101))
- .S RI=$G(^DPT(DFN,.108)) S RE=$S(RI:$O(^FH(119.6,"AR",+RI,W1,0)),1:"")
- .S R0=$S(RE:$P($G(^FH(119.6,W1,"R",+RE,0)),"^",2),1:"")
- .S R0=$S(R0<1:99,R0<10:"0"_R0,1:R0)
- .S PNOD=P0_"~"_R0_RM_"~"_DFN,X=^DPT(DFN,0) D PID^FHDPA
- .S XY=^FHPT(FHDFN,"A",ADM,"TF",TF,0)
- .S ^TMP($J,"T",TNOD,PNOD,0)=$E($P(X,"^",1),1,22)_"^"_BID_"^"_WARD_"^"_RM_"^"_$P(XY,"^",5,7) Q
- F TF2=0:0 S TF2=$O(^FHPT(FHDFN,"A",ADM,"TF",TF,"P",TF2)) Q:TF2<1 S YY=^(TF2,0) D LP
- Q
- LP S TP=$P(YY,"^",4) D PREP
- I "135"[FHOPT S:'$D(^TMP($J,"C",CNOD,TUN,0)) ^(0)="" S $P(^(0),"^",1)=$P(^(0),"^",1)+TU,$P(^(0),"^",2)=$P(^(0),"^",2)+1
- I "124"[FHOPT S ^TMP($J,"T",TNOD,PNOD,TF2,0)=$P(Y0,"^",1)_"^"_$P(Y0,"^",2)_"^"_TP_"^"_TW_"^"_TU_"^"_P1_"^"_STR_"^"_QUA_"^"_TUN
- Q
- Q3 K ^FHPT("ADTF",FHDFN,ADM)
- I $D(^FHPT(FHDFN,"A",ADM,0)) S TF=$P(^(0),"^",4),$P(^(0),"^",4)="" I TF>0,$D(^FHPT(FHDFN,"A",ADM,"TF",TF,0)) S $P(^(0),"^",11)=NOW,ORIFN=$P(^(0),"^",14) I ORIFN S ORSTS=1 D ST^ORX
- Q
- PREP ; Calculate Preparation
- S TUN=$P(YY,"^",1),Y0=$G(^FH(118.2,TUN,0)) Q:Y0=""
- S STR=$P(YY,"^",2),QUA=$P(YY,"^",3)
- I QUA["CC" S QUAFI=$P(QUA,"CC",1),QUASE=$P(QUA,"CC",2),QUA=QUAFI_"ML"_QUASE
- I $E($P(Y0,"^",3),$L($P(Y0,"^",3)))="G" D GRM Q
- S TU=$P(YY,"^",4)/$S(+$P(Y0,"^",3):+$P(Y0,"^",3),1:9999),TW=$P(YY,"^",5)
- ;I TW<6 S TP="",TW="",TU=TU+.75\1,P1=TU Q ;NOIS MWV-0303-21626
- I TW<6 S TP="",TW="",(TU,P1)=TU+.9999\1 Q
- S TU=TU+.2*4\1/4,TP=$J(TP/10,0)*10,TW=$J(TW/10,0)*10
- S P1=$S(TU<1:"",1:TU\1) I TU#1 S:P1 P1=P1_"-" S P2=TU#1,P1=P1_$S(P2<.3:"1/4",P2<.6:"1/2",1:"3/4")
- Q
- GRM ; Calculate Gram
- S TW=0,X=QUA D FIX^FHORT10 S Z5="" F L=1:1:$L(X) I $E(X,L)'=" " S Z5=Z5_$E(X,L)
- S Z5=$P(Z5,"/",2),Z5=$P(Z5,"X",2)
- I 'Z5 S Z5=$P("1,24,2,3,12,8,6,4",",",K) G G1
- I Z5'["F" S Z5=$S(K=1:1,K=2:Z5,K=3:2,K=4:3,K=5:Z5\2,K=6:Z5\3,K=7:Z5\4,1:Z5\6)
- E S:K=1 Z5=1
- G1 S TU=+QUA*Z5
- S TU=TU/$S(+$P(Y0,"^",3):+$P(Y0,"^",3),1:9999)
- ;S P1=$S(TU<1:"",1:TU\1) I P1="" S TU=TU+.95\1,P1=TU
- S P1=$S(TU<1:"",1:TU\1)
- I P1="" S TU=TU+.999\1,P1=TU
- E S TU=TU+.999\1
- I TU#1 S:P1 P1=P1_"-" S TU=TU#1,P1=P1_$S(TU<.3:"1/4",TU<.6:"1/2",1:"3/4")
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHORT5A 5438 printed Mar 13, 2025@20:58:36 Page 2
- FHORT5A ; HISC/REL/NCA/RVD - Tubefeeding Reports (cont) ;3/1/04 13:15
- +1 ;;5.5;DIETETICS;**1,3,5**;Jan 28, 2005;Build 53
- +2 ;
- Q1 ; Print Tubefeeding Report
- +1 SET PG=0
- DO NOW^%DTC
- SET (DTP,NOW)=%
- DO DTP^FH
- KILL ^TMP($JOB)
- INPAT ;get inpatient data
- +1 FOR FHDFN=0:0
- SET FHDFN=$ORDER(^FHPT("ADTF",FHDFN))
- if FHDFN<1
- QUIT
- FOR ADM=0:0
- SET ADM=$ORDER(^FHPT("ADTF",FHDFN,ADM))
- if ADM<1
- QUIT
- DO PATNAME^FHOMUTL
- if DFN=""
- QUIT
- DO Q2
- +2 ;
- OUTPAT ;get outpatient data, for today's date.
- +1 FOR FHDFN=0:0
- SET FHDFN=$ORDER(^FHPT("RM",DT,FHDFN))
- if FHDFN'>0
- QUIT
- FOR FHFIN=0:0
- SET FHFIN=$ORDER(^FHPT("RM",DT,FHDFN,FHFIN))
- if FHFIN'>0
- QUIT
- Begin DoDot:1
- +2 ;quit if TF is cancelled
- +3 IF $DATA(^FHPT(FHDFN,"OP",FHFIN,3))
- IF $PIECE(^(3),U,5)="C"
- QUIT
- +4 SET (FHRMB,RM)=" "
- +5 IF $DATA(^FHPT(FHDFN,"OP",FHFIN,0))
- SET FHRMB=$PIECE($GET(^FHPT(FHDFN,"OP",FHFIN,0)),U,18)
- +6 IF $GET(FHRMB)
- IF $DATA(^DG(405.4,FHRMB,0))
- SET RM=$PIECE(^DG(405.4,FHRMB,0),U,1)
- +7 FOR FHTF=0:0
- SET FHTF=$ORDER(^FHPT(FHDFN,"OP",FHFIN,"TF",FHTF))
- if FHTF'>0
- QUIT
- Begin DoDot:2
- +8 if '$DATA(^FHPT(FHDFN,"OP",FHFIN,"TF",FHTF,0))
- QUIT
- +9 SET YY=$GET(^FHPT(FHDFN,"OP",FHFIN,"TF",FHTF,0))
- +10 ;
- +11 SET TF2=FHTF
- +12 SET Z=$GET(^FHPT(FHDFN,"OP",FHFIN,0))
- +13 SET XY=$GET(^FHPT(FHDFN,"OP",FHFIN,3))
- +14 SET (Z1,Z2)=""
- SET W1=$PIECE(Z,"^",3)
- +15 SET P0=$GET(^FH(119.6,+W1,0))
- SET Z3=$PIECE(P0,"^",8)
- SET WARD=$EXTRACT($PIECE(P0,"^",1),U,12)
- +16 SET CC=$PIECE($GET(^FH(119.73,+Z3,0)),"^",1)
- +17 IF FHXX="C"
- SET D2=$PIECE(P0,"^",8)
- IF FHP
- IF FHP'=D2
- QUIT
- +18 IF FHXX="L"
- IF FHP
- IF FHP'=W1
- QUIT
- +19 SET P0=$PIECE(P0,"^",4)
- SET P0=$SELECT(P0<1:99,P0<10:"0"_P0,1:P0)
- +20 SET TNOD=$SELECT(FHXX="C":"99~"_CC,1:P0_"~"_WARD)
- SET CNOD=$SELECT('SUM:TNOD,1:"0")
- +21 ;
- +22 IF FHOPT=3
- Begin DoDot:3
- +23 SET CTR=$GET(^TMP($JOB,"C",CNOD,0))
- +24 ;I "^^^^"[FHOR S:Z2 $P(CTR,"^",1)=$P(CTR,"^",1)+1 S:Z2 $P(CTR,"^",3)=$P(CTR,"^",3)+1
- +25 SET $PIECE(CTR,"^",1)=$PIECE(CTR,"^",1)+1
- +26 ;I "^^^^"'[FHOR,Z1="T" S:'Z2 $P(CTR,"^",2)=$P(CTR,"^",2)+1 S:Z2 $P(CTR,"^",4)=$P(CTR,"^",4)+1
- +27 SET ^TMP($JOB,"C",CNOD,0)=CTR
- QUIT
- End DoDot:3
- +28 ;
- +29 SET TP=$PIECE(YY,"^",4)
- DO PREP
- +30 ;set ^tmp global for specific report.
- +31 DO PATNAME^FHOMUTL
- +32 SET PNOD=P0_"~"_WARD_"~"_FHDFN
- +33 IF "135"[FHOPT
- if '$DATA(^TMP($JOB,"C",CNOD,TUN,0))
- SET ^(0)=""
- SET $PIECE(^(0),"^",1)=$PIECE(^(0),"^",1)+TU
- SET $PIECE(^(0),"^",2)=$PIECE(^(0),"^",2)+1
- +34 IF "124"[FHOPT
- Begin DoDot:3
- +35 if '$DATA(^TMP($JOB,"T",TNOD,PNOD,0))
- SET ^(0)=$EXTRACT(FHPTNM,1,22)_"^"_FHBID_"^"_WARD_"^"_RM_"^"_$PIECE(XY,"^",1,3)
- +36 SET ^TMP($JOB,"T",TNOD,PNOD,TF2,0)=$PIECE(Y0,"^",1)_"^"_$PIECE(Y0,"^",2)_"^"_TP_"^"_TW_"^"_TU_"^"_P1_"^"_STR_"^"_QUA_"^"_TUN
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +37 ;
- PRT ;prints corresponding reports.
- +1 IF FHOPT=1
- DO PREP^FHORT5B
- DO PULL^FHORT5C
- DO DEL^FHORT5C
- QUIT
- +2 IF FHOPT=2
- DO PREP^FHORT5B
- QUIT
- +3 IF FHOPT=3
- DO CST^FHORT5D
- QUIT
- +4 IF FHOPT=4
- DO LAB^FHORT5D
- QUIT
- +5 IF FHOPT=5
- DO PULL^FHORT5C
- +6 QUIT
- Q2 SET Z=$GET(^FHPT(FHDFN,"A",ADM,0))
- SET WARD=$PIECE(Z,"^",8)
- if WARD
- SET WARD=$PIECE($GET(^FH(119.6,WARD,0)),"^",1)
- IF WARD=""
- GOTO Q3
- +1 if '$DATA(^DPT(DFN,.1))
- GOTO Q3
- SET CADM=$GET(^DPT("CN",^DPT(DFN,.1),DFN))
- if ADM'=CADM
- GOTO Q3
- +2 SET TF=$PIECE(Z,"^",4)
- if TF<1
- GOTO Q3
- +3 SET Z1=$PIECE(Z,"^",5)
- SET Z2=$PIECE(Z,"^",7)
- SET W1=$PIECE(Z,"^",8)
- SET P0=$GET(^FH(119.6,+W1,0))
- SET Z3=$PIECE(P0,"^",8)
- SET CC=$PIECE($GET(^FH(119.73,+Z3,0)),"^",1)
- +4 IF FHXX="C"
- SET D2=$PIECE(P0,"^",8)
- IF FHP
- IF FHP'=D2
- QUIT
- +5 IF FHXX="L"
- IF FHP
- IF FHP'=W1
- QUIT
- +6 SET P0=$PIECE(P0,"^",4)
- SET P0=$SELECT(P0<1:99,P0<10:"0"_P0,1:P0)
- +7 SET TNOD=$SELECT(FHXX="C":"99~"_CC,1:P0_"~"_WARD)
- SET CNOD=$SELECT('SUM:TNOD,1:"0")
- +8 DO CUR^FHORD7
- IF FHLD="P"
- QUIT
- +9 IF FHOPT=3
- Begin DoDot:1
- +10 SET CTR=$GET(^TMP($JOB,"C",CNOD,0))
- +11 IF "^^^^"[FHOR
- if 'Z2
- SET $PIECE(CTR,"^",1)=$PIECE(CTR,"^",1)+1
- if Z2
- SET $PIECE(CTR,"^",3)=$PIECE(CTR,"^",3)+1
- +12 IF "^^^^"'[FHOR
- IF Z1="T"
- if 'Z2
- SET $PIECE(CTR,"^",2)=$PIECE(CTR,"^",2)+1
- if Z2
- SET $PIECE(CTR,"^",4)=$PIECE(CTR,"^",4)+1
- +13 SET ^TMP($JOB,"C",CNOD,0)=CTR
- QUIT
- End DoDot:1
- +14 IF "124"[FHOPT
- Begin DoDot:1
- +15 SET RM=$GET(^DPT(DFN,.101))
- +16 SET RI=$GET(^DPT(DFN,.108))
- SET RE=$SELECT(RI:$ORDER(^FH(119.6,"AR",+RI,W1,0)),1:"")
- +17 SET R0=$SELECT(RE:$PIECE($GET(^FH(119.6,W1,"R",+RE,0)),"^",2),1:"")
- +18 SET R0=$SELECT(R0<1:99,R0<10:"0"_R0,1:R0)
- +19 SET PNOD=P0_"~"_R0_RM_"~"_DFN
- SET X=^DPT(DFN,0)
- DO PID^FHDPA
- +20 SET XY=^FHPT(FHDFN,"A",ADM,"TF",TF,0)
- +21 SET ^TMP($JOB,"T",TNOD,PNOD,0)=$EXTRACT($PIECE(X,"^",1),1,22)_"^"_BID_"^"_WARD_"^"_RM_"^"_$PIECE(XY,"^",5,7)
- QUIT
- End DoDot:1
- +22 FOR TF2=0:0
- SET TF2=$ORDER(^FHPT(FHDFN,"A",ADM,"TF",TF,"P",TF2))
- if TF2<1
- QUIT
- SET YY=^(TF2,0)
- DO LP
- +23 QUIT
- LP SET TP=$PIECE(YY,"^",4)
- DO PREP
- +1 IF "135"[FHOPT
- if '$DATA(^TMP($JOB,"C",CNOD,TUN,0))
- SET ^(0)=""
- SET $PIECE(^(0),"^",1)=$PIECE(^(0),"^",1)+TU
- SET $PIECE(^(0),"^",2)=$PIECE(^(0),"^",2)+1
- +2 IF "124"[FHOPT
- SET ^TMP($JOB,"T",TNOD,PNOD,TF2,0)=$PIECE(Y0,"^",1)_"^"_$PIECE(Y0,"^",2)_"^"_TP_"^"_TW_"^"_TU_"^"_P1_"^"_STR_"^"_QUA_"^"_TUN
- +3 QUIT
- Q3 KILL ^FHPT("ADTF",FHDFN,ADM)
- +1 IF $DATA(^FHPT(FHDFN,"A",ADM,0))
- SET TF=$PIECE(^(0),"^",4)
- SET $PIECE(^(0),"^",4)=""
- IF TF>0
- IF $DATA(^FHPT(FHDFN,"A",ADM,"TF",TF,0))
- SET $PIECE(^(0),"^",11)=NOW
- SET ORIFN=$PIECE(^(0),"^",14)
- IF ORIFN
- SET ORSTS=1
- DO ST^ORX
- +2 QUIT
- PREP ; Calculate Preparation
- +1 SET TUN=$PIECE(YY,"^",1)
- SET Y0=$GET(^FH(118.2,TUN,0))
- if Y0=""
- QUIT
- +2 SET STR=$PIECE(YY,"^",2)
- SET QUA=$PIECE(YY,"^",3)
- +3 IF QUA["CC"
- SET QUAFI=$PIECE(QUA,"CC",1)
- SET QUASE=$PIECE(QUA,"CC",2)
- SET QUA=QUAFI_"ML"_QUASE
- +4 IF $EXTRACT($PIECE(Y0,"^",3),$LENGTH($PIECE(Y0,"^",3)))="G"
- DO GRM
- QUIT
- +5 SET TU=$PIECE(YY,"^",4)/$SELECT(+$PIECE(Y0,"^",3):+$PIECE(Y0,"^",3),1:9999)
- SET TW=$PIECE(YY,"^",5)
- +6 ;I TW<6 S TP="",TW="",TU=TU+.75\1,P1=TU Q ;NOIS MWV-0303-21626
- +7 IF TW<6
- SET TP=""
- SET TW=""
- SET (TU,P1)=TU+.9999\1
- QUIT
- +8 SET TU=TU+.2*4\1/4
- SET TP=$JUSTIFY(TP/10,0)*10
- SET TW=$JUSTIFY(TW/10,0)*10
- +9 SET P1=$SELECT(TU<1:"",1:TU\1)
- IF TU#1
- if P1
- SET P1=P1_"-"
- SET P2=TU#1
- SET P1=P1_$SELECT(P2<.3:"1/4",P2<.6:"1/2",1:"3/4")
- +10 QUIT
- GRM ; Calculate Gram
- +1 SET TW=0
- SET X=QUA
- DO FIX^FHORT10
- SET Z5=""
- FOR L=1:1:$LENGTH(X)
- IF $EXTRACT(X,L)'=" "
- SET Z5=Z5_$EXTRACT(X,L)
- +2 SET Z5=$PIECE(Z5,"/",2)
- SET Z5=$PIECE(Z5,"X",2)
- +3 IF 'Z5
- SET Z5=$PIECE("1,24,2,3,12,8,6,4",",",K)
- GOTO G1
- +4 IF Z5'["F"
- SET Z5=$SELECT(K=1:1,K=2:Z5,K=3:2,K=4:3,K=5:Z5\2,K=6:Z5\3,K=7:Z5\4,1:Z5\6)
- +5 IF '$TEST
- if K=1
- SET Z5=1
- G1 SET TU=+QUA*Z5
- +1 SET TU=TU/$SELECT(+$PIECE(Y0,"^",3):+$PIECE(Y0,"^",3),1:9999)
- +2 ;S P1=$S(TU<1:"",1:TU\1) I P1="" S TU=TU+.95\1,P1=TU
- +3 SET P1=$SELECT(TU<1:"",1:TU\1)
- +4 IF P1=""
- SET TU=TU+.999\1
- SET P1=TU
- +5 IF '$TEST
- SET TU=TU+.999\1
- +6 IF TU#1
- if P1
- SET P1=P1_"-"
- SET TU=TU#1
- SET P1=P1_$SELECT(TU<.3:"1/4",TU<.6:"1/2",1:"3/4")
- +7 QUIT
