Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSGDCTP

PSGDCTP.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ; Resort data by if by amt or cost.
  1. K ^TMP($J,"S2") S PSGP2=$S(PSGDCT=1:0,1:$D(PSGDISP)),PSGWO=$S('$D(PSGDCLW):0,1:'PSGP2),S1=""
  1. F S S1=$O(^TMP($J,"S1",S1)) Q:S1=""!(S1="RST") S ND=$G(^(S1,0)) I '$$EXCLUDE(ND) D
  1. .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
  1. .S S2=0 F S S2=$O(^TMP($J,"S1",S1,S2)) Q:S2="" S ND=$G(^(S2,0)) I ND>0 D
  1. ..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
  1. ..S S3=0 F S S3=$O(^TMP($J,"S1",S1,S2,S3)) Q:S3="" S ND=$G(^(S3,0)) I ND>0 D
  1. ...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
  1. D START
  1. Q
  1. ;
  1. DONE ;Kill and EXIT.
  1. W:CML&($Y) @IOF
  1. 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
  1. 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
  1. K OIND,PSGDASUM,PSGDT,PSGID,PSJSYSL,PSJSYSP,PSJSYSP0,PSJSYSU
  1. Q
  1. EXCLUDE(X) ; Check if drug data should be included.
  1. S C=$P(ND,U,2)
  1. I (ND!C),(PSGDCTL=""!(C'<PSGDCTL)),(PSGDCTA=""!(ND'<PSGDCTA)) Q 0
  1. Q 1
  1. ;
  1. SETRST(X,ND) ; Set RSTx subscripts
  1. Q $S("CA"'[X:"ZZ",X="C":-(+$P(ND,U,2)),1:-(+ND))
  1. ;
  1. START ;
  1. N DIRUT
  1. D NOW^%DTC S PSGDT=%,CML=IO'=IO(0)!(IOST'["C-"),(NP,LN1)="",$P(LN1,"-",81)=""
  1. U IO D HDR I '$D(^TMP($J,"S2")) W !!?25,"*** NO DRUG COST DATA FOUND ***" D DONE Q
  1. ;
  1. PRINT ;Print Data
  1. S (PSGCSUM,PSGASUM)=0,PSG1="" F S PSG1=$O(^TMP($J,"S2",PSG1)) Q:PSG1=""!$D(DIRUT) D
  1. .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"))
  1. ..S ND=$G(^TMP($J,"S2",PSG1,PSG2)),PSGSASUM=+ND,PSGSCSUM=$P(ND,U,2),PSGASUM=PSGASUM+PSGSASUM,PSGCSUM=PSGCSUM+PSGSCSUM
  1. ..W ! W:PSGDCT=1&$P(ND,U,3) "**" W ?2,$P(ND,U,4) D:'PSGP2&'$D(PSGDCLW) WRTAC
  1. ..S PSG3="" F S PSG3=$O(^TMP($J,"S2",PSG1,PSG2,PSG3)) Q:PSG3=""!$D(DIRUT) D
  1. ...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")
  1. ....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
  1. ....S PSG5="" F S PSG5=$O(^TMP($J,"S2",PSG1,PSG2,PSG3,PSG4,PSG5)) Q:PSG5=""!$D(DIRUT) D
  1. .....S PSG6="" F S PSG6=$O(^TMP($J,"S2",PSG1,PSG2,PSG3,PSG4,PSG5,PSG6)) Q:PSG6=""!$D(DIRUT) S ND=$G(^(PSG6)) D
  1. ......W !,?10,$P(ND,U,4) D WRTAC
  1. D:'$D(DIRUT) SUM(PSGASUM,PSGCSUM,"L")
  1. Q
  1. ;
  1. WRTAC ; Print amt, cost line.
  1. W ?50,$J(+ND,8,3),?70,$J($P(ND,U,2),8,4) D:$Y+7>IOSL EOP
  1. Q
  1. ;
  1. HDR ;Report Header.
  1. W:$Y @IOF W !!?28,"UNIT DOSE DRUG COST REPORT",?63,$$ENDTC^PSGMI(PSGDT),!?25,"FROM ",STRT," THROUGH ",STOP,!!
  1. D:'PSGP2&'$D(PSGDCLW) HDR1
  1. W PSGDCT(1) D:$D(PSGDCLW)&'PSGP2 HDR1
  1. I PSGP2 W !?5,"DISPENSED DRUG"
  1. D:$D(PSGDCLW)&$D(PSGDISP) HDR1
  1. W:$D(PSGDCLW) ?(5+(PSGP2*5)),"WARD" W ?50,"DISPENSED",?74,"COST",!,LN1,!
  1. Q
  1. HDR1 W ?48,"TOTAL UNITS",?73,"TOTAL",!
  1. Q
  1. ;
  1. SUM(AMT,CST,TYP) ;Print totals and subtotals
  1. Q:$D(DIRUT)
  1. 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),!
  1. I TYP="L",NP'["^",CML W !!?54,"(** = NON-FORMULARY ITEM)"
  1. I $Y+7>IOSL,(TYP'="L") D EOP
  1. Q
  1. ;
  1. EOP ;Check for end of page.
  1. I 'CML K DIR S DIR(0)="E" D ^DIR Q:$D(DIRUT)
  1. I CML W !!?54,"(** = NON-FORMULARY ITEM) "
  1. D HDR
  1. Q