- PSIVPAT ;BIR/PR-PATIENT COST REPORT ;07 OCT 97 / 9:48 AM
- ;;5.0; INPATIENT MEDICATIONS ;;16 DEC 97
- K ^UTILITY($J) S Y=I7 X ^DD("DD") S HEAD=Y,Y=I8 X ^DD("DD") S HEAD=HEAD_" THROUGH "_Y,Y=DT X ^DD("DD") S DATE=Y
- F IV=0:0 S IV=$O(^PS(50.8,IV)) Q:'IV I $D(^(IV,2)) F DAT=I7-1:0 S DAT=$O(^PS(50.8,IV,2,DAT)) Q:'DAT!(DAT>I8) D ND
- PRTQUE G:'$D(I6) W S ZTIO=I6,ZTDESC="IV PATIENT COST REPORT (PRINT)",ZTRTN="W^PSIVPAT",ZTDTH=$H
- S ZTSAVE("^UTILITY($J,")="" F G="I7","I8","I5","I4","I15","I6","HEAD","PC","DATE","DX","PSJSYSU","PSJSYSP0" S ZTSAVE(G)=""
- S %ZIS="QN",IOP=I6 D ^%ZIS,^%ZTLOAD G K
- W I '$D(VAIN) S DFN=I5 D ENIV^PSJAC K DFN
- U IO S DRG="",(TOTDIS,TOTCOS,PC,TOTRT,RT,UD,DEST,TOTCAN)=0 D H G P S:$D(ZTQUEUED) ZTREQ="@"
- Q
- ;
- ND I $D(^PS(50.8,IV,2,DAT,2)) F DA=0:0 S DA=$O(^PS(50.8,IV,2,DAT,2,DA)) Q:'DA I $D(^(DA,0)),$D(^(1,I5,0)) D B
- Q
- ;
- B S G1=^PS(50.8,IV,2,DAT,2,DA,0),DRUG=$P(G1,U),UC=$P(G1,U,5),G1=$P(G1,U,6)
- S UD=$P(^PS(50.8,IV,2,DAT,2,DA,1,I5,0),U,2),RT=$P(^(0),U,3),DEST=$P(^(0),U,4),CAN=$P(^(0),U,6)
- S G=$S($D(^UTILITY($J,I5,DRUG)):^(DRUG),1:UC_U_G1),^(DRUG)=$P(G,U,1,2)_U_($P(G,U,3)+UD)_U_(UD-RT-CAN*UC+$P(G,U,4))_U_($P(G,U,5)+RT)_U_($P(G,U,6)+DEST)_U_($P(G,U,7)+CAN)
- Q
- ;
- H ;Header
- W:$Y @IOF S PC=PC+1 W ?97,$J(DATE,13),!!
- W !?51,"PATIENT COST REPORT FOR:",?97,"PAGE ",$J(PC,3)
- W !?51,VADM(1)," PID: ",VA("PID"),!?51,HEAD
- W !?51,"WARD: ",$S(VAIN(4)]"":$P(VAIN(4),U,2),1:"OUTPATIENT") W:VAIN(5)]"" " ",VAIN(5)
- W !,?51,"DOB: ",$S(VADM(3)]"":$P(VADM(3),U,2),1:"NF")," ","SEX: ",$S(VADM(5)]"":$P(VADM(5),U,2),1:"NF")
- W !?51,"Weight (kg): ",$S(+PSJPWT:+PSJPWT,1:"NF")
- W !?51,"DX: ",$S(VAIN(9)'="":VAIN(9),1:"NF")
- W !!!!,"DRUG NAME",?39,"DISPENSED",?57,"(DESTROYED)",?78,"RECYCLED",?101,"CANCELLED",?123,"DRUG COST",!
- F LN=1:1:132 W "="
- W !
- Q
- P ;
- I '$D(^UTILITY($J)) W !!,$C(7),"No data exists." W:$E(IOST)'="C"&($Y) @IOF D ^%ZISC G K
- F JJ=0:0 S DRG=$O(^UTILITY($J,I5,DRG)) Q:DRG="" D P1
- G P2
- P1 ;
- S G=^UTILITY($J,I5,DRG),C=$P(G,U,2),CC=$P(^DD(52.6,2,0),U,3),CC=$P(CC,";",C),CC=$P(CC,":",2),C=CC K CC
- S TOTDIS=TOTDIS+$P(G,U,3),TOTCOS=TOTCOS+$P(G,U,4),TOTRT=TOTRT+$P(G,U,5),TOTCAN=TOTCAN+$P(G,U,7)
- W !,$E(DRG,1,37),?38,$J($P(G,U,3),10,2)_" "_C,?60,$J($P(G,U,6),8,2),?78,$J($P(G,U,5),8,2),?99,$J($P(G,U,7),10,2),?116,"$",$J($P(G,U,4),15,4)
- D:$Y+4>IOSL H
- Q
- P2 W !,?117,"==============="
- W !,?20,"GRAND TOTAL:",?116,"$",$J(TOTCOS,15,4) D TM^PSIVDCR1
- K ;
- S:$D(ZTQUEUED) ZTREQ="@"
- K ^UTILITY($J),DRUG,DRG,C,G1,DATE,G,HEAD,LN,DA,RT,ST,TOTCOS,TOTDIS,TOTRT,UC,UD,PC,I8,I7,I5,SEX,WT,Y,X3,X4,X5,DX,IV,Z,%I,CAN,DAT,DEST,TOTCAN,%H Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSIVPAT 2609 printed Jan 18, 2025@03:06:03 Page 2
- PSIVPAT ;BIR/PR-PATIENT COST REPORT ;07 OCT 97 / 9:48 AM
- +1 ;;5.0; INPATIENT MEDICATIONS ;;16 DEC 97
- +2 KILL ^UTILITY($JOB)
- SET Y=I7
- XECUTE ^DD("DD")
- SET HEAD=Y
- SET Y=I8
- XECUTE ^DD("DD")
- SET HEAD=HEAD_" THROUGH "_Y
- SET Y=DT
- XECUTE ^DD("DD")
- SET DATE=Y
- +3 FOR IV=0:0
- SET IV=$ORDER(^PS(50.8,IV))
- if 'IV
- QUIT
- IF $DATA(^(IV,2))
- FOR DAT=I7-1:0
- SET DAT=$ORDER(^PS(50.8,IV,2,DAT))
- if 'DAT!(DAT>I8)
- QUIT
- DO ND
- PRTQUE if '$DATA(I6)
- GOTO W
- SET ZTIO=I6
- SET ZTDESC="IV PATIENT COST REPORT (PRINT)"
- SET ZTRTN="W^PSIVPAT"
- SET ZTDTH=$HOROLOG
- +1 SET ZTSAVE("^UTILITY($J,")=""
- FOR G="I7","I8","I5","I4","I15","I6","HEAD","PC","DATE","DX","PSJSYSU","PSJSYSP0"
- SET ZTSAVE(G)=""
- +2 SET %ZIS="QN"
- SET IOP=I6
- DO ^%ZIS
- DO ^%ZTLOAD
- GOTO K
- W IF '$DATA(VAIN)
- SET DFN=I5
- DO ENIV^PSJAC
- KILL DFN
- +1 USE IO
- SET DRG=""
- SET (TOTDIS,TOTCOS,PC,TOTRT,RT,UD,DEST,TOTCAN)=0
- DO H
- GOTO P
- if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +2 QUIT
- +3 ;
- ND IF $DATA(^PS(50.8,IV,2,DAT,2))
- FOR DA=0:0
- SET DA=$ORDER(^PS(50.8,IV,2,DAT,2,DA))
- if 'DA
- QUIT
- IF $DATA(^(DA,0))
- IF $DATA(^(1,I5,0))
- DO B
- +1 QUIT
- +2 ;
- B SET G1=^PS(50.8,IV,2,DAT,2,DA,0)
- SET DRUG=$PIECE(G1,U)
- SET UC=$PIECE(G1,U,5)
- SET G1=$PIECE(G1,U,6)
- +1 SET UD=$PIECE(^PS(50.8,IV,2,DAT,2,DA,1,I5,0),U,2)
- SET RT=$PIECE(^(0),U,3)
- SET DEST=$PIECE(^(0),U,4)
- SET CAN=$PIECE(^(0),U,6)
- +2 SET G=$SELECT($DATA(^UTILITY($JOB,I5,DRUG)):^(DRUG),1:UC_U_G1)
- SET ^(DRUG)=$PIECE(G,U,1,2)_U_($PIECE(G,U,3)+UD)_U_(UD-RT-CAN*UC+$PIECE(G,U,4))_U_($PIECE(G,U,5)+RT)_U_($PIECE(G,U,6)+DEST)_U_($PIECE(G,U,7)+CAN)
- +3 QUIT
- +4 ;
- H ;Header
- +1 if $Y
- WRITE @IOF
- SET PC=PC+1
- WRITE ?97,$JUSTIFY(DATE,13),!!
- +2 WRITE !?51,"PATIENT COST REPORT FOR:",?97,"PAGE ",$JUSTIFY(PC,3)
- +3 WRITE !?51,VADM(1)," PID: ",VA("PID"),!?51,HEAD
- +4 WRITE !?51,"WARD: ",$SELECT(VAIN(4)]"":$PIECE(VAIN(4),U,2),1:"OUTPATIENT")
- if VAIN(5)]""
- WRITE " ",VAIN(5)
- +5 WRITE !,?51,"DOB: ",$SELECT(VADM(3)]"":$PIECE(VADM(3),U,2),1:"NF")," ","SEX: ",$SELECT(VADM(5)]"":$PIECE(VADM(5),U,2),1:"NF")
- +6 WRITE !?51,"Weight (kg): ",$SELECT(+PSJPWT:+PSJPWT,1:"NF")
- +7 WRITE !?51,"DX: ",$SELECT(VAIN(9)'="":VAIN(9),1:"NF")
- +8 WRITE !!!!,"DRUG NAME",?39,"DISPENSED",?57,"(DESTROYED)",?78,"RECYCLED",?101,"CANCELLED",?123,"DRUG COST",!
- +9 FOR LN=1:1:132
- WRITE "="
- +10 WRITE !
- +11 QUIT
- P ;
- +1 IF '$DATA(^UTILITY($JOB))
- WRITE !!,$CHAR(7),"No data exists."
- if $EXTRACT(IOST)'="C"&($Y)
- WRITE @IOF
- DO ^%ZISC
- GOTO K
- +2 FOR JJ=0:0
- SET DRG=$ORDER(^UTILITY($JOB,I5,DRG))
- if DRG=""
- QUIT
- DO P1
- +3 GOTO P2
- P1 ;
- +1 SET G=^UTILITY($JOB,I5,DRG)
- SET C=$PIECE(G,U,2)
- SET CC=$PIECE(^DD(52.6,2,0),U,3)
- SET CC=$PIECE(CC,";",C)
- SET CC=$PIECE(CC,":",2)
- SET C=CC
- KILL CC
- +2 SET TOTDIS=TOTDIS+$PIECE(G,U,3)
- SET TOTCOS=TOTCOS+$PIECE(G,U,4)
- SET TOTRT=TOTRT+$PIECE(G,U,5)
- SET TOTCAN=TOTCAN+$PIECE(G,U,7)
- +3 WRITE !,$EXTRACT(DRG,1,37),?38,$JUSTIFY($PIECE(G,U,3),10,2)_" "_C,?60,$JUSTIFY($PIECE(G,U,6),8,2),?78,$JUSTIFY($PIECE(G,U,5),8,2),?99,$JUSTIFY($PIECE(G,U,7),10,2),?116,"$",$JUSTIFY($PIECE(G,U,4),15,4)
- +4 if $Y+4>IOSL
- DO H
- +5 QUIT
- P2 WRITE !,?117,"==============="
- +1 WRITE !,?20,"GRAND TOTAL:",?116,"$",$JUSTIFY(TOTCOS,15,4)
- DO TM^PSIVDCR1
- K ;
- +1 if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +2 KILL ^UTILITY($JOB),DRUG,DRG,C,G1,DATE,G,HEAD,LN,DA,RT,ST,TOTCOS,TOTDIS,TOTRT,UC,UD,PC,I8,I7,I5,SEX,WT,Y,X3,X4,X5,DX,IV,Z,%I,CAN,DAT,DEST,TOTCAN,%H
- QUIT