- PSGDCTP ;BIR/DAV,MLM-SORT AND PRINT DRUG PROFILE DATA ;1 NOV 95 / 8:55 AM
- ;;5.0; INPATIENT MEDICATIONS ;**132**;16 DEC 97
- ;
- ; Resort data by if by amt or cost.
- K ^TMP($J,"S2") S PSGP2=$S(PSGDCT=1:0,1:$D(PSGDISP)),PSGWO=$S('$D(PSGDCLW):0,1:'PSGP2),S1=""
- F S S1=$O(^TMP($J,"S1",S1)) Q:S1=""!(S1="RST") S ND=$G(^(S1,0)) I '$$EXCLUDE(ND) D
- .S RST1=$$SETRST(PSGDCTS,ND),$P(ND,U,4)=$P(S1,U),PSG1=$E($P(S1,U),1,20)_U_$P(S1,U,2),^TMP($J,"S2",RST1,PSG1)=ND
- .S S2=0 F S S2=$O(^TMP($J,"S1",S1,S2)) Q:S2="" S ND=$G(^(S2,0)) I ND>0 D
- ..S RST3=$$SETRST(PSGDCTS,ND) I $D(PSGDISP)!PSGWO S PSG2=$E($P(S2,U),1,20)_U_$P(S2,U,2),$P(ND,U,4)=$P(S2,U),^TMP($J,"S2",RST1,PSG1,RST3,PSG2)=ND
- ..S S3=0 F S S3=$O(^TMP($J,"S1",S1,S2,S3)) Q:S3="" S ND=$G(^(S3,0)) I ND>0 D
- ...S RST5=$$SETRST(PSGDCTS,ND),$P(ND,U,4)=$P(S3,U),^TMP($J,"S2",RST1,PSG1,RST3,PSG2,RST5,$E($P(S3,U,2),1,20))=ND
- D START
- Q
- ;
- DONE ;Kill and EXIT.
- W:CML&($Y) @IOF
- DONE1 D ENCV^PSGSETU K ^TMP($J),CML,DRG,FD,HLP,LN1,ND,ND50,NP,OI,PD,PR,PSG,PSG1,PSG2,PSG3,PSG4,PSG5,PSG6,PSGASUM,PSGCLW,PSGCSUM,PSGCTL,PSGCTS,PSGDCLW,PSGDCSUM
- K PSGDCT,PSGDCTA,PSGDCTD,PSGDCTL,PSGDCTS,PSGDISP,PSGERR,PSGP2,PSGSASUM,PSGSCSUM,PSGWO,RST1,RST3,RST5,RTN,S1,S2,S3,SD,ST,STOP,STRT,TYP,W,WD,X,Y
- K OIND,PSGDASUM,PSGDT,PSGID,PSJSYSL,PSJSYSP,PSJSYSP0,PSJSYSU
- Q
- EXCLUDE(X) ; Check if drug data should be included.
- S C=$P(ND,U,2)
- I (ND!C),(PSGDCTL=""!(C'<PSGDCTL)),(PSGDCTA=""!(ND'<PSGDCTA)) Q 0
- Q 1
- ;
- SETRST(X,ND) ; Set RSTx subscripts
- Q $S("CA"'[X:"ZZ",X="C":-(+$P(ND,U,2)),1:-(+ND))
- ;
- START ;
- N DIRUT
- D NOW^%DTC S PSGDT=%,CML=IO'=IO(0)!(IOST'["C-"),(NP,LN1)="",$P(LN1,"-",81)=""
- U IO D HDR I '$D(^TMP($J,"S2")) W !!?25,"*** NO DRUG COST DATA FOUND ***" D DONE Q
- ;
- PRINT ;Print Data
- S (PSGCSUM,PSGASUM)=0,PSG1="" F S PSG1=$O(^TMP($J,"S2",PSG1)) Q:PSG1=""!$D(DIRUT) D
- .S PSG2="" F S PSG2=$O(^TMP($J,"S2",PSG1,PSG2)) Q:PSG2=""!$D(DIRUT) D D:PSGP2!$D(PSGDCLW) SUM(PSGSASUM,PSGSCSUM,$S(PSGDCT=1:"D",1:"S"))
- ..S ND=$G(^TMP($J,"S2",PSG1,PSG2)),PSGSASUM=+ND,PSGSCSUM=$P(ND,U,2),PSGASUM=PSGASUM+PSGSASUM,PSGCSUM=PSGCSUM+PSGSCSUM
- ..W ! W:PSGDCT=1&$P(ND,U,3) "**" W ?2,$P(ND,U,4) D:'PSGP2&'$D(PSGDCLW) WRTAC
- ..S PSG3="" F S PSG3=$O(^TMP($J,"S2",PSG1,PSG2,PSG3)) Q:PSG3=""!$D(DIRUT) D
- ...S PSG4="" F S PSG4=$O(^TMP($J,"S2",PSG1,PSG2,PSG3,PSG4)) Q:PSG4=""!$D(DIRUT) S ND=$G(^(PSG4)) D D:$D(PSGDCLW)&'PSGWO SUM(PSGDASUM,PSGDCSUM,"D")
- ....S PSGDASUM=+ND,PSGDCSUM=$P(ND,U,2) I PSGP2!PSGWO W !?3,$S($P(ND,U,3)="":" ",1:"**"),$P(ND,U,4) D:'$D(PSGDCLW)!PSGWO WRTAC
- ....S PSG5="" F S PSG5=$O(^TMP($J,"S2",PSG1,PSG2,PSG3,PSG4,PSG5)) Q:PSG5=""!$D(DIRUT) D
- .....S PSG6="" F S PSG6=$O(^TMP($J,"S2",PSG1,PSG2,PSG3,PSG4,PSG5,PSG6)) Q:PSG6=""!$D(DIRUT) S ND=$G(^(PSG6)) D
- ......W !,?10,$P(ND,U,4) D WRTAC
- D:'$D(DIRUT) SUM(PSGASUM,PSGCSUM,"L")
- Q
- ;
- WRTAC ; Print amt, cost line.
- W ?50,$J(+ND,8,3),?70,$J($P(ND,U,2),8,4) D:$Y+7>IOSL EOP
- Q
- ;
- HDR ;Report Header.
- W:$Y @IOF W !!?28,"UNIT DOSE DRUG COST REPORT",?63,$$ENDTC^PSGMI(PSGDT),!?25,"FROM ",STRT," THROUGH ",STOP,!!
- D:'PSGP2&'$D(PSGDCLW) HDR1
- W PSGDCT(1) D:$D(PSGDCLW)&'PSGP2 HDR1
- I PSGP2 W !?5,"DISPENSED DRUG"
- D:$D(PSGDCLW)&$D(PSGDISP) HDR1
- W:$D(PSGDCLW) ?(5+(PSGP2*5)),"WARD" W ?50,"DISPENSED",?74,"COST",!,LN1,!
- Q
- HDR1 W ?48,"TOTAL UNITS",?73,"TOTAL",!
- Q
- ;
- SUM(AMT,CST,TYP) ;Print totals and subtotals
- Q:$D(DIRUT)
- W !?51,"---------------------------",!,?22 W $J($S(TYP="S":PSGDCT(1),TYP="D":"DISPENSE DRUG",1:""),13)," " W:TYP'="L" "Sub-" W ?39,"Total:",?50,$J(AMT,8,3),?70,$J(CST,8,4),!
- I TYP="L",NP'["^",CML W !!?54,"(** = NON-FORMULARY ITEM)"
- I $Y+7>IOSL,(TYP'="L") D EOP
- Q
- ;
- EOP ;Check for end of page.
- I 'CML K DIR S DIR(0)="E" D ^DIR Q:$D(DIRUT)
- I CML W !!?54,"(** = NON-FORMULARY ITEM) "
- D HDR
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGDCTP 3800 printed Feb 18, 2025@23:27:27 Page 2
- PSGDCTP ;BIR/DAV,MLM-SORT AND PRINT DRUG PROFILE DATA ;1 NOV 95 / 8:55 AM
- +1 ;;5.0; INPATIENT MEDICATIONS ;**132**;16 DEC 97
- +2 ;
- +3 ; Resort data by if by amt or cost.
- +4 KILL ^TMP($JOB,"S2")
- SET PSGP2=$SELECT(PSGDCT=1:0,1:$DATA(PSGDISP))
- SET PSGWO=$SELECT('$DATA(PSGDCLW):0,1:'PSGP2)
- SET S1=""
- +5 FOR
- SET S1=$ORDER(^TMP($JOB,"S1",S1))
- if S1=""!(S1="RST")
- QUIT
- SET ND=$GET(^(S1,0))
- IF '$$EXCLUDE(ND)
- Begin DoDot:1
- +6 SET RST1=$$SETRST(PSGDCTS,ND)
- SET $PIECE(ND,U,4)=$PIECE(S1,U)
- SET PSG1=$EXTRACT($PIECE(S1,U),1,20)_U_$PIECE(S1,U,2)
- SET ^TMP($JOB,"S2",RST1,PSG1)=ND
- +7 SET S2=0
- FOR
- SET S2=$ORDER(^TMP($JOB,"S1",S1,S2))
- if S2=""
- QUIT
- SET ND=$GET(^(S2,0))
- IF ND>0
- Begin DoDot:2
- +8 SET RST3=$$SETRST(PSGDCTS,ND)
- IF $DATA(PSGDISP)!PSGWO
- SET PSG2=$EXTRACT($PIECE(S2,U),1,20)_U_$PIECE(S2,U,2)
- SET $PIECE(ND,U,4)=$PIECE(S2,U)
- SET ^TMP($JOB,"S2",RST1,PSG1,RST3,PSG2)=ND
- +9 SET S3=0
- FOR
- SET S3=$ORDER(^TMP($JOB,"S1",S1,S2,S3))
- if S3=""
- QUIT
- SET ND=$GET(^(S3,0))
- IF ND>0
- Begin DoDot:3
- +10 SET RST5=$$SETRST(PSGDCTS,ND)
- SET $PIECE(ND,U,4)=$PIECE(S3,U)
- SET ^TMP($JOB,"S2",RST1,PSG1,RST3,PSG2,RST5,$EXTRACT($PIECE(S3,U,2),1,20))=ND
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +11 DO START
- +12 QUIT
- +13 ;
- DONE ;Kill and EXIT.
- +1 if CML&($Y)
- WRITE @IOF
- DONE1 DO ENCV^PSGSETU
- KILL ^TMP($JOB),CML,DRG,FD,HLP,LN1,ND,ND50,NP,OI,PD,PR,PSG,PSG1,PSG2,PSG3,PSG4,PSG5,PSG6,PSGASUM,PSGCLW,PSGCSUM,PSGCTL,PSGCTS,PSGDCLW,PSGDCSUM
- +1 KILL PSGDCT,PSGDCTA,PSGDCTD,PSGDCTL,PSGDCTS,PSGDISP,PSGERR,PSGP2,PSGSASUM,PSGSCSUM,PSGWO,RST1,RST3,RST5,RTN,S1,S2,S3,SD,ST,STOP,STRT,TYP,W,WD,X,Y
- +2 KILL OIND,PSGDASUM,PSGDT,PSGID,PSJSYSL,PSJSYSP,PSJSYSP0,PSJSYSU
- +3 QUIT
- EXCLUDE(X) ; Check if drug data should be included.
- +1 SET C=$PIECE(ND,U,2)
- +2 IF (ND!C)
- IF (PSGDCTL=""!(C'<PSGDCTL))
- IF (PSGDCTA=""!(ND'<PSGDCTA))
- QUIT 0
- +3 QUIT 1
- +4 ;
- SETRST(X,ND) ; Set RSTx subscripts
- +1 QUIT $SELECT("CA"'[X:"ZZ",X="C":-(+$PIECE(ND,U,2)),1:-(+ND))
- +2 ;
- START ;
- +1 NEW DIRUT
- +2 DO NOW^%DTC
- SET PSGDT=%
- SET CML=IO'=IO(0)!(IOST'["C-")
- SET (NP,LN1)=""
- SET $PIECE(LN1,"-",81)=""
- +3 USE IO
- DO HDR
- IF '$DATA(^TMP($JOB,"S2"))
- WRITE !!?25,"*** NO DRUG COST DATA FOUND ***"
- DO DONE
- QUIT
- +4 ;
- PRINT ;Print Data
- +1 SET (PSGCSUM,PSGASUM)=0
- SET PSG1=""
- FOR
- SET PSG1=$ORDER(^TMP($JOB,"S2",PSG1))
- if PSG1=""!$DATA(DIRUT)
- QUIT
- Begin DoDot:1
- +2 SET PSG2=""
- FOR
- SET PSG2=$ORDER(^TMP($JOB,"S2",PSG1,PSG2))
- if PSG2=""!$DATA(DIRUT)
- QUIT
- Begin DoDot:2
- +3 SET ND=$GET(^TMP($JOB,"S2",PSG1,PSG2))
- SET PSGSASUM=+ND
- SET PSGSCSUM=$PIECE(ND,U,2)
- SET PSGASUM=PSGASUM+PSGSASUM
- SET PSGCSUM=PSGCSUM+PSGSCSUM
- +4 WRITE !
- if PSGDCT=1&$PIECE(ND,U,3)
- WRITE "**"
- WRITE ?2,$PIECE(ND,U,4)
- if 'PSGP2&'$DATA(PSGDCLW)
- DO WRTAC
- +5 SET PSG3=""
- FOR
- SET PSG3=$ORDER(^TMP($JOB,"S2",PSG1,PSG2,PSG3))
- if PSG3=""!$DATA(DIRUT)
- QUIT
- Begin DoDot:3
- +6 SET PSG4=""
- FOR
- SET PSG4=$ORDER(^TMP($JOB,"S2",PSG1,PSG2,PSG3,PSG4))
- if PSG4=""!$DATA(DIRUT)
- QUIT
- SET ND=$GET(^(PSG4))
- Begin DoDot:4
- +7 SET PSGDASUM=+ND
- SET PSGDCSUM=$PIECE(ND,U,2)
- IF PSGP2!PSGWO
- WRITE !?3,$SELECT($PIECE(ND,U,3)="":" ",1:"**"),$PIECE(ND,U,4)
- if '$DATA(PSGDCLW)!PSGWO
- DO WRTAC
- +8 SET PSG5=""
- FOR
- SET PSG5=$ORDER(^TMP($JOB,"S2",PSG1,PSG2,PSG3,PSG4,PSG5))
- if PSG5=""!$DATA(DIRUT)
- QUIT
- Begin DoDot:5
- +9 SET PSG6=""
- FOR
- SET PSG6=$ORDER(^TMP($JOB,"S2",PSG1,PSG2,PSG3,PSG4,PSG5,PSG6))
- if PSG6=""!$DATA(DIRUT)
- QUIT
- SET ND=$GET(^(PSG6))
- Begin DoDot:6
- +10 WRITE !,?10,$PIECE(ND,U,4)
- DO WRTAC
- End DoDot:6
- End DoDot:5
- End DoDot:4
- if $DATA(PSGDCLW)&'PSGWO
- DO SUM(PSGDASUM,PSGDCSUM,"D")
- End DoDot:3
- End DoDot:2
- if PSGP2!$DATA(PSGDCLW)
- DO SUM(PSGSASUM,PSGSCSUM,$SELECT(PSGDCT=1:"D",1:"S"))
- End DoDot:1
- +11 if '$DATA(DIRUT)
- DO SUM(PSGASUM,PSGCSUM,"L")
- +12 QUIT
- +13 ;
- WRTAC ; Print amt, cost line.
- +1 WRITE ?50,$JUSTIFY(+ND,8,3),?70,$JUSTIFY($PIECE(ND,U,2),8,4)
- if $Y+7>IOSL
- DO EOP
- +2 QUIT
- +3 ;
- HDR ;Report Header.
- +1 if $Y
- WRITE @IOF
- WRITE !!?28,"UNIT DOSE DRUG COST REPORT",?63,$$ENDTC^PSGMI(PSGDT),!?25,"FROM ",STRT," THROUGH ",STOP,!!
- +2 if 'PSGP2&'$DATA(PSGDCLW)
- DO HDR1
- +3 WRITE PSGDCT(1)
- if $DATA(PSGDCLW)&'PSGP2
- DO HDR1
- +4 IF PSGP2
- WRITE !?5,"DISPENSED DRUG"
- +5 if $DATA(PSGDCLW)&$DATA(PSGDISP)
- DO HDR1
- +6 if $DATA(PSGDCLW)
- WRITE ?(5+(PSGP2*5)),"WARD"
- WRITE ?50,"DISPENSED",?74,"COST",!,LN1,!
- +7 QUIT
- HDR1 WRITE ?48,"TOTAL UNITS",?73,"TOTAL",!
- +1 QUIT
- +2 ;
- SUM(AMT,CST,TYP) ;Print totals and subtotals
- +1 if $DATA(DIRUT)
- QUIT
- +2 WRITE !?51,"---------------------------",!,?22
- WRITE $JUSTIFY($SELECT(TYP="S":PSGDCT(1),TYP="D":"DISPENSE DRUG",1:""),13)," "
- if TYP'="L"
- WRITE "Sub-"
- WRITE ?39,"Total:",?50,$JUSTIFY(AMT,8,3),?70,$JUSTIFY(CST,8,4),!
- +3 IF TYP="L"
- IF NP'["^"
- IF CML
- WRITE !!?54,"(** = NON-FORMULARY ITEM)"
- +4 IF $Y+7>IOSL
- IF (TYP'="L")
- DO EOP
- +5 QUIT
- +6 ;
- EOP ;Check for end of page.
- +1 IF 'CML
- KILL DIR
- SET DIR(0)="E"
- DO ^DIR
- if $DATA(DIRUT)
- QUIT
- +2 IF CML
- WRITE !!?54,"(** = NON-FORMULARY ITEM) "
- +3 DO HDR
- +4 QUIT