- FHORT5D ; HISC/REL/NCA/RVD - Tubefeeding Reports (cont) ;5/4/93 10:52
- ;;5.5;DIETETICS;;Jan 28, 2005
- ;
- CST ; Print Cost Report for Tubefeeding
- S NAM="" F S NAM=$O(^FH(118.2,"B",NAM)) Q:NAM="" F LL=0:0 S LL=$O(^FH(118.2,"B",NAM,LL)) Q:LL<1 S ^TMP($J,"P",NAM_"~"_LL)=LL
- I SUM S CNOD="0" D C2 Q
- S CNOD="0" F S CNOD=$O(^TMP($J,"C",CNOD)) Q:CNOD="" D C2
- Q
- C2 S D2=0,NAM="" D HD4 S X0=$G(^TMP($J,"C",CNOD,0))
- F S NAM=$O(^TMP($J,"P",NAM)) Q:NAM="" S LL=^(NAM) I $D(^TMP($J,"C",CNOD,LL)) S X1=$G(^(LL,0)),TU=$P(X1,"^",1),TP=$P(X1,"^",2) D
- .I $Y>(IOSL-8) D HD4
- .S Y0=^FH(118.2,LL,0),TU=TU+.95\1,PR=$P($G(^FH(114,+$P(Y0,"^",7),0)),"^",13),D2=TU*PR+D2
- .W !,$P(Y0,"^",1),?31,$J($S(TP:TP,1:0),5),?41,$P(Y0,"^",2),?53,$J(TU,5),?62,$J(PR,7,2),?72,$J(TU*PR,7,2) Q
- W !!,"Total: ",?71,$J(D2,8,2),!!!,"No. of Patients on TF: ",?33,$J($P(X0,"^",1),6)
- W !,"No. of Patients on TF and Tray: ",?33,$J($P(X0,"^",2),6),!,"No. of Patients on TF and SF: ",?33,$J($P(X0,"^",3),6)
- W !,"No. of Patients on ALL Three: ",?33,$J($P(X0,"^",4),6),!,"Cost/Patient: ",?33 S X=$P(X0,"^",1) W $J($S(X:D2/X,1:""),6,2),! Q
- LAB ; Print Labels
- S LAB=$P($G(^FH(119.9,1,"D",IOS,0)),"^",2) S:'LAB LAB=1 S S1=$S(LAB=1:6,1:9),S2=LAB=2*5+33
- S COUNT=0,LINE=1
- S TNOD="" F S TNOD=$O(^TMP($J,"T",TNOD)) Q:TNOD="" D L1
- I LAB>2 D DPLL^FHLABEL Q
- W !!!!!!!!!!!!!!!!!! Q
- L1 S PNOD="" F S PNOD=$O(^TMP($J,"T",TNOD,PNOD)) Q:PNOD="" S X0=^(PNOD,0) D L2
- Q
- L2 S NAM=$P(X0,"^",1),WARD=$P(X0,"^",3),RM=$P(X0,"^",4),X3=3
- F TF2=0:0 S TF2=$O(^TMP($J,"T",TNOD,PNOD,TF2)) Q:'TF2 S X1=^(TF2,0),X3=X3+3 D L3
- Q
- L3 S Y0=$P(X1,"^",1),STR=$P(X1,"^",7),Y1="" I STR<4 S Y1=$S(STR=1:"1/4",STR=2:"1/2",1:"3/4")_" Str, "
- S Y1=Y1_$P(X1,"^",8),Y0=Y0_", "_$S('MUL:$P(X1,"^",6),1:1)_" "_$P(X1,"^",2) I 'MUL,$P(X1,"^",6)>1 S Y0=Y0_"S"
- I LAB>2 D LL Q
- I 'MUL D LHDR W !,Y0,!,Y1,! W:LAB=2 !!! Q
- F X2=1:1:+$P(X1,"^",6) D LHDR W !,Y0,!,Y1,! W:LAB=2 !!!
- Q
- LHDR ; Label Header
- W !,NAM,?(S2-$L(WARD)),WARD,!,$P(X0,"^",2),?8,$E(DTP,1,9),?(S2-$L(RM)),RM,! Q
- HD4 ; Cost Report Header
- W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1
- W !,$E(DTP,1,9),?17,"T U B E F E E D I N G C O S T R E P O R T",?73,"Page ",PG
- S Y=$S(SUM:"CONSOLIDATED",1:$P(CNOD,"~",2)) W !!?(80-$L(Y)\2),Y
- W !!,"Product",?30,"# Patient",?41,"Unit",?53,"# Units",?62,"Cost/Unit",?74,"Total",! Q
- Q
- LL ;
- S FHCOL=$S(LAB=3:3,1:2)
- I LABSTART>1 F FHLABST=1:1:(LABSTART-1)*FHCOL D S LABSTART=1
- .I LAB=3 S (PCL1,PCL2,PCL3,PCL4,PCL5,PCL6)="" D LL3^FHLABEL
- .I LAB=4 S (PCL1,PCL2,PCL3,PCL4,PCL5,PCL6,PCL7,PCL8)="" D LL4^FHLABEL
- .Q
- S FHTAB=$S(LAB=3:24,1:37)
- S NAM=$E(NAM,1,FHTAB-$L(WARD)),X02P=$P(X0,U,2),DTP=$E(DTP,1,9)
- S X0DTP=X02P_$E(" ",1,7-$L(X02P))_DTP
- S LNA=NAM_$J(WARD,FHTAB+1-$L(NAM))
- S LNB=X0DTP_$J($E(RM,1,8),FHTAB+1-$L(X0DTP))
- I 'MUL D LLB Q
- I MUL F X2=1:1:+$P(X1,"^",6) D LLB
- Q
- LLB ;
- S FHST=$S(LAB=3:25,1:38)
- S FHN=FHST F CN=FHST:-1:FHST-5 S Y0X=$E(Y0,CN) I Y0X="," S FHN=CN Q
- I LAB=3 S PCL1="",PCL2=LNA,PCL3=LNB,PCL4=$E(Y0,1,FHN),PCL5=$E(Y0,FHN+1,99),PCL6=Y1
- I LAB=4 S (PCL1,PCL2,PCL8)="",PCL3=LNA,PCL4=LNB,PCL5=$E(Y0,1,FHN),PCL6=$E(Y0,FHN+1,99),PCL7=Y1
- D:LAB=3 LL3^FHLABEL D:LAB=4 LL4^FHLABEL
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHORT5D 3201 printed Apr 23, 2025@18:08:27 Page 2
- FHORT5D ; HISC/REL/NCA/RVD - Tubefeeding Reports (cont) ;5/4/93 10:52
- +1 ;;5.5;DIETETICS;;Jan 28, 2005
- +2 ;
- CST ; Print Cost Report for Tubefeeding
- +1 SET NAM=""
- FOR
- SET NAM=$ORDER(^FH(118.2,"B",NAM))
- if NAM=""
- QUIT
- FOR LL=0:0
- SET LL=$ORDER(^FH(118.2,"B",NAM,LL))
- if LL<1
- QUIT
- SET ^TMP($JOB,"P",NAM_"~"_LL)=LL
- +2 IF SUM
- SET CNOD="0"
- DO C2
- QUIT
- +3 SET CNOD="0"
- FOR
- SET CNOD=$ORDER(^TMP($JOB,"C",CNOD))
- if CNOD=""
- QUIT
- DO C2
- +4 QUIT
- C2 SET D2=0
- SET NAM=""
- DO HD4
- SET X0=$GET(^TMP($JOB,"C",CNOD,0))
- +1 FOR
- SET NAM=$ORDER(^TMP($JOB,"P",NAM))
- if NAM=""
- QUIT
- SET LL=^(NAM)
- IF $DATA(^TMP($JOB,"C",CNOD,LL))
- SET X1=$GET(^(LL,0))
- SET TU=$PIECE(X1,"^",1)
- SET TP=$PIECE(X1,"^",2)
- Begin DoDot:1
- +2 IF $Y>(IOSL-8)
- DO HD4
- +3 SET Y0=^FH(118.2,LL,0)
- SET TU=TU+.95\1
- SET PR=$PIECE($GET(^FH(114,+$PIECE(Y0,"^",7),0)),"^",13)
- SET D2=TU*PR+D2
- +4 WRITE !,$PIECE(Y0,"^",1),?31,$JUSTIFY($SELECT(TP:TP,1:0),5),?41,$PIECE(Y0,"^",2),?53,$JUSTIFY(TU,5),?62,$JUSTIFY(PR,7,2),?72,$JUSTIFY(TU*PR,7,2)
- QUIT
- End DoDot:1
- +5 WRITE !!,"Total: ",?71,$JUSTIFY(D2,8,2),!!!,"No. of Patients on TF: ",?33,$JUSTIFY($PIECE(X0,"^",1),6)
- +6 WRITE !,"No. of Patients on TF and Tray: ",?33,$JUSTIFY($PIECE(X0,"^",2),6),!,"No. of Patients on TF and SF: ",?33,$JUSTIFY($PIECE(X0,"^",3),6)
- +7 WRITE !,"No. of Patients on ALL Three: ",?33,$JUSTIFY($PIECE(X0,"^",4),6),!,"Cost/Patient: ",?33
- SET X=$PIECE(X0,"^",1)
- WRITE $JUSTIFY($SELECT(X:D2/X,1:""),6,2),!
- QUIT
- LAB ; Print Labels
- +1 SET LAB=$PIECE($GET(^FH(119.9,1,"D",IOS,0)),"^",2)
- if 'LAB
- SET LAB=1
- SET S1=$SELECT(LAB=1:6,1:9)
- SET S2=LAB=2*5+33
- +2 SET COUNT=0
- SET LINE=1
- +3 SET TNOD=""
- FOR
- SET TNOD=$ORDER(^TMP($JOB,"T",TNOD))
- if TNOD=""
- QUIT
- DO L1
- +4 IF LAB>2
- DO DPLL^FHLABEL
- QUIT
- +5 WRITE !!!!!!!!!!!!!!!!!!
- QUIT
- L1 SET PNOD=""
- FOR
- SET PNOD=$ORDER(^TMP($JOB,"T",TNOD,PNOD))
- if PNOD=""
- QUIT
- SET X0=^(PNOD,0)
- DO L2
- +1 QUIT
- L2 SET NAM=$PIECE(X0,"^",1)
- SET WARD=$PIECE(X0,"^",3)
- SET RM=$PIECE(X0,"^",4)
- SET X3=3
- +1 FOR TF2=0:0
- SET TF2=$ORDER(^TMP($JOB,"T",TNOD,PNOD,TF2))
- if 'TF2
- QUIT
- SET X1=^(TF2,0)
- SET X3=X3+3
- DO L3
- +2 QUIT
- L3 SET Y0=$PIECE(X1,"^",1)
- SET STR=$PIECE(X1,"^",7)
- SET Y1=""
- IF STR<4
- SET Y1=$SELECT(STR=1:"1/4",STR=2:"1/2",1:"3/4")_" Str, "
- +1 SET Y1=Y1_$PIECE(X1,"^",8)
- SET Y0=Y0_", "_$SELECT('MUL:$PIECE(X1,"^",6),1:1)_" "_$PIECE(X1,"^",2)
- IF 'MUL
- IF $PIECE(X1,"^",6)>1
- SET Y0=Y0_"S"
- +2 IF LAB>2
- DO LL
- QUIT
- +3 IF 'MUL
- DO LHDR
- WRITE !,Y0,!,Y1,!
- if LAB=2
- WRITE !!!
- QUIT
- +4 FOR X2=1:1:+$PIECE(X1,"^",6)
- DO LHDR
- WRITE !,Y0,!,Y1,!
- if LAB=2
- WRITE !!!
- +5 QUIT
- LHDR ; Label Header
- +1 WRITE !,NAM,?(S2-$LENGTH(WARD)),WARD,!,$PIECE(X0,"^",2),?8,$EXTRACT(DTP,1,9),?(S2-$LENGTH(RM)),RM,!
- QUIT
- HD4 ; Cost Report Header
- +1 if '($EXTRACT(IOST,1,2)'="C-"&'PG)
- WRITE @IOF
- SET PG=PG+1
- +2 WRITE !,$EXTRACT(DTP,1,9),?17,"T U B E F E E D I N G C O S T R E P O R T",?73,"Page ",PG
- +3 SET Y=$SELECT(SUM:"CONSOLIDATED",1:$PIECE(CNOD,"~",2))
- WRITE !!?(80-$LENGTH(Y)\2),Y
- +4 WRITE !!,"Product",?30,"# Patient",?41,"Unit",?53,"# Units",?62,"Cost/Unit",?74,"Total",!
- QUIT
- +5 QUIT
- LL ;
- +1 SET FHCOL=$SELECT(LAB=3:3,1:2)
- +2 IF LABSTART>1
- FOR FHLABST=1:1:(LABSTART-1)*FHCOL
- Begin DoDot:1
- +3 IF LAB=3
- SET (PCL1,PCL2,PCL3,PCL4,PCL5,PCL6)=""
- DO LL3^FHLABEL
- +4 IF LAB=4
- SET (PCL1,PCL2,PCL3,PCL4,PCL5,PCL6,PCL7,PCL8)=""
- DO LL4^FHLABEL
- +5 QUIT
- End DoDot:1
- SET LABSTART=1
- +6 SET FHTAB=$SELECT(LAB=3:24,1:37)
- +7 SET NAM=$EXTRACT(NAM,1,FHTAB-$LENGTH(WARD))
- SET X02P=$PIECE(X0,U,2)
- SET DTP=$EXTRACT(DTP,1,9)
- +8 SET X0DTP=X02P_$EXTRACT(" ",1,7-$LENGTH(X02P))_DTP
- +9 SET LNA=NAM_$JUSTIFY(WARD,FHTAB+1-$LENGTH(NAM))
- +10 SET LNB=X0DTP_$JUSTIFY($EXTRACT(RM,1,8),FHTAB+1-$LENGTH(X0DTP))
- +11 IF 'MUL
- DO LLB
- QUIT
- +12 IF MUL
- FOR X2=1:1:+$PIECE(X1,"^",6)
- DO LLB
- +13 QUIT
- LLB ;
- +1 SET FHST=$SELECT(LAB=3:25,1:38)
- +2 SET FHN=FHST
- FOR CN=FHST:-1:FHST-5
- SET Y0X=$EXTRACT(Y0,CN)
- IF Y0X=","
- SET FHN=CN
- QUIT
- +3 IF LAB=3
- SET PCL1=""
- SET PCL2=LNA
- SET PCL3=LNB
- SET PCL4=$EXTRACT(Y0,1,FHN)
- SET PCL5=$EXTRACT(Y0,FHN+1,99)
- SET PCL6=Y1
- +4 IF LAB=4
- SET (PCL1,PCL2,PCL8)=""
- SET PCL3=LNA
- SET PCL4=LNB
- SET PCL5=$EXTRACT(Y0,1,FHN)
- SET PCL6=$EXTRACT(Y0,FHN+1,99)
- SET PCL7=Y1
- +5 if LAB=3
- DO LL3^FHLABEL
- if LAB=4
- DO LL4^FHLABEL
- +6 QUIT
