- PSSOIDOS ;BIR/RTR-Orderable Item/Dosage review report ;03/24/00
- ;;1.0;PHARMACY DATA MANAGEMENT;**40**;9/30/97
- EN ;
- K PSSHOW,PSSBEG,PSSEND,PSSSRT
- K DIR S DIR(0)="S^A:ALL;S:SELECT A RANGE",DIR("B")="S",DIR("A")="Print Report for (A)ll or (S)elect a Range" D D ^DIR K DIR I Y["^"!($D(DTOUT))!($D(DUOUT)) W !!,"Nothing queued to print.",! G ENDX
- .S DIR("?")=" ",DIR("?",1)="Enter 'A' to run report for all Orderable Items. Enter 'S' to select a range",DIR("?",2)="(alphabetically) of Orderable Items to print."
- S PSSHOW=Y I PSSHOW="A" S PSSBEG="A",PSSEND="Z" S PSSSRT="A" G DEV
- ;W !!,"To see drugs beginning with the letter 'A', enter 'A', or whichever letter you",!,"wish to see. To see drugs in a range, for example drugs starting with the",!,"letters 'G', 'H', 'I' and 'J', enter in the format 'G-J'.",!
- ASK ;
- K DIR,PSSBEG,PSSEND,PSSNUMBX
- S PSSNUMB=""
- F S PSSNUMB=$O(^PS(50.7,"B",PSSNUMB)) Q:'PSSNUMB!($G(PSSNUMBX)) S PSSNUMBX=1
- I $G(PSSNUMBX) K DIR S DIR(0)="Y",DIR("A")="Print report for Orderable Items with leading numerics",DIR("B")="N" D D ^DIR K DIR I Y["^"!($D(DUOUT))!($D(DTOUT)) W !!,"Nothing queued to print.",! G ENDX
- .W !!!,"There are entries in the Orderable Item file with leading numerics.",!
- .S DIR("?")=" ",DIR("?",1)="There are some entries in the Orderable Item file with leading numerics.",DIR("?",2)="Enter Yes to print the report for those drugs.",DIR("?",3)=" "
- I $G(PSSNUMBX),$G(Y)=1 S PSSSRT="N" G DEV
- K PSSNUMB,PSSNUMBX
- ASKA K PSSBEG,PSSEND
- W !!,"To see items beginning with the letter 'A', enter 'A', or whichever letter you",!,"wish to see. To see items in a range, for example items starting with the",!,"letters 'G', 'H', 'I' and 'J', enter in the format 'G-J'.",!
- S DIR("?",1)=" ",DIR("?",2)="Enter either 1 letter, 'A', 'B', etc., to see items beginning with that letter,",DIR("?",3)="or to see a range of items enter in the format 'A-C', 'G-M', 'S-Z', etc.",DIR("?",4)=" ",DIR("?")=" "
- S DIR("A")="Select a Range",DIR(0)="F^1:3" D ^DIR I Y["^"!($D(DTOUT))!($D(DUOUT)) W !!,"Nothing queued to print.",! G ENDX
- S X=Y I X'?1U&(X'?1U1"-"1U)&(X'?1L)&(X'?1L1"-"1L) W !!,"Invalid response, enter a letter, 'A', 'B', etc., or a range, 'C-F', 'M-R', etc.",! G ASKA
- I X["-" S PSSBEG=$P(X,"-"),PSSEND=$P(X,"-",2) I $A(PSSEND)<$A(PSSBEG) W !!,"Invalid response.",! G ASKA
- I X'["-" S PSSBEG=X,PSSEND=X
- S PSSSRT="X"
- DEV I PSSSRT="X" W !!,"Report will be for items starting with the letter "_$G(PSSBEG)_",",!,"and ending with items starting with the letter "_$G(PSSEND)_".",!
- I PSSSRT="N" W !!,"This report will be for items with leading numerics.",!
- I PSSSRT="A" W !!,"This report will be for all items.",!
- K DIR S DIR(0)="Y",DIR("A")="Is this correct",DIR("B")="Y" D ^DIR K DIR I Y'=1 W ! G EN
- ;W $C(7),!!?3,"This report is designed for 132 column format!",!
- W ! K IOP,%ZIS,POP S %ZIS="QM" D ^%ZIS I $G(POP) W !!,"Nothing queued to print.",! G ENDX
- I $D(IO("Q")) S ZTRTN="START^PSSOIDOS",ZTDESC="Orderable Item/Dosages Review Report",ZTSAVE("PSSHOW")="",ZTSAVE("PSSBEG")="",ZTSAVE("PSSEND")="",ZTSAVE("PSSSRT")="" D ^%ZTLOAD K %ZIS W !,"Report queued to print.",! G ENDX
- START ;
- U IO
- I '$G(DT) S DT=$$DT^XLFDT
- S X1=DT,X2=-365 D C^%DTC S PSSYEAR=$G(X) K X,X1,X2
- S PSSOUT=0,PSSDV=$S($E(IOST)="C":"C",1:"P"),PSSCT=1
- K PSSLINE,PSSIEND S $P(PSSLINE,"-",78)=""
- D HD
- G:PSSSRT="N" PASS
- S PSSX=$A(PSSBEG)-1
- S PSSNAME=$C(PSSX)_"zzzz"
- PASS ;
- I $G(PSSSRT)="N" S (PSSNAME,PSSEND)=""
- I $G(PSSSRT)="A" S (PSSNAME,PSSEND)=""
- F S PSSNAME=$O(^PS(50.7,"ADF",PSSNAME)) Q:$S(PSSSRT="N"&('PSSNAME):1,PSSSRT="X"&(PSSNAME](PSSEND_"zzzz")):1,1:0)!(PSSNAME=""&(PSSSRT="X"))!(PSSSRT="A"&(PSSNAME=""))!($G(PSSOUT)) D
- .F PSSIEND=0:0 S PSSIEND=$O(^PS(50.7,"ADF",PSSNAME,PSSIEND)) Q:'PSSIEND!($G(PSSOUT)) F PSSIEN=0:0 S PSSIEN=$O(^PS(50.7,"ADF",PSSNAME,PSSIEND,PSSIEN)) Q:'PSSIEN!($G(PSSOUT)) D
- ..Q:'$D(^PS(50.7,PSSIEN,0))
- ..Q:$P($G(^PS(50.7,PSSIEN,0)),"^",3)
- ..I ($Y+5)>IOSL D HD Q:$G(PSSOUT)
- ..K PSSINA,PSSNF,PSSINAD,PSSUNIT,PSSAPU S PSSINA=$P($G(^PS(50.7,PSSIEN,0)),"^",4)
- ..I $G(PSSINA),$G(PSSYEAR),$G(PSSINA)<$G(PSSYEAR) Q
- ..I $G(PSSINA) S PSSINAD=$E(PSSINA,4,5)_"/"_$E(PSSINA,6,7)_"/"_$E(PSSINA,2,3)
- ..S PSSLEN=$P($G(^PS(50.7,PSSIEN,0)),"^")_" "_$P($G(^PS(50.606,+$P($G(^PS(50.7,PSSIEN,0)),"^",2),0)),"^")
- ..W !!,$G(PSSLEN)
- ..I ($Y+5)>IOSL D HD Q:$G(PSSOUT)
- ..I $G(PSSINA) D
- ...I $L(PSSLEN)>62 W !,?64,$G(PSSINAD) Q
- ...W ?64,$G(PSSINAD)
- ..I ($Y+5)>IOSL D HD Q:$G(PSSOUT)
- ..K PSSINP,PSSINPZ D DOSE^PSSORUTZ(.PSSINP,PSSIEN,"U") D
- ...I '$O(PSSINP(0)) Q
- ...W !?2,"Inpatient Dosages:"
- ...F PSSINPX=0:0 S PSSINPX=$O(PSSINP(PSSINPX)) Q:'PSSINPX!($G(PSSOUT)) D
- ....I ($Y+5)>IOSL D HD Q:$G(PSSOUT)
- ....S PSSLZ=$P($G(PSSINP(PSSINPX)),"^",5) W !?4,PSSLZ
- ....I $L(PSSLZ)>32 W !
- ....W ?38,$P($G(PSSINP("DD",+$P($G(PSSINP(PSSINPX)),"^",6))),"^")
- ..Q:$G(PSSOUT)
- ..K PSSOUP,PSSOUPZ,PSSLZZZ D DOSE^PSSORUTZ(.PSSOUP,PSSIEN,"O") D
- ...I '$O(PSSOUP(0)) Q
- ...W !?2,"Outpatient Dosages:"
- ...F PSSOUPX=0:0 S PSSOUPX=$O(PSSOUP(PSSOUPX)) Q:'PSSOUPX!($G(PSSOUT)) D
- ....I ($Y+5)>IOSL D HD Q:$G(PSSOUT)
- ....S PSSLZ=$P($G(PSSOUP(PSSOUPX)),"^",5) W !?4,PSSLZ
- ....K PSSLZZZ I $P($G(PSSOUP(PSSOUPX)),"^")'="" S PSSLZZZ="("_$P($G(PSSOUP(PSSOUPX)),"^",3)_" "_$P($G(PSSOUP(PSSOUPX)),"^",4)_")"
- ....I $S($L(PSSLZ)>10&($G(PSSLZZZ)'=""):1,$L(PSSLZ)>32:1,1:0) W !
- ....I $G(PSSLZZZ)'="" W ?16,$G(PSSLZZZ) I $L(PSSLZZZ)>20 W !
- ....W ?38,$P($G(PSSOUP("DD",+$P($G(PSSOUP(PSSOUPX)),"^",6))),"^")
- END ;
- I '$G(PSSOUT),$G(PSSDV)="C" W !!,"End of Report." K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
- I $G(PSSDV)="C" W !
- E W @IOF
- ENDX K PSSOUP,PSSOUPX,PSSINP,PSSINPX,PSSOUPZ,PSSINPZ,PSSLZ,PSSLZZZ
- K PSSNODE,PSSLEN,PSSIEND,PSSNUMB,PSSNUMBX,PSSSRT,PSSCALC,PSSSTR,PSSUNIT,PSSIEN,PSSINAD,PSSINA,PSSNF,PSSNAME,PSSDV,PSSX,PSSOUT,PSSHOW,PSSBEG,PSSLINE,PSSEND,PSSA,PSSB,PSSC,PSSD,PSSE,PSSAPU,PSSMSG,PSSYEAR D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
- Q
- HD ;
- I $G(PSSDV)="C",$G(PSSCT)'=1 W ! K DIR S DIR(0)="E",DIR("A")="Press Return to continue, '^' to exit" D ^DIR K DIR I 'Y S PSSOUT=1 Q
- W @IOF W !,$S(PSSSRT="N":"Dosage report for Orderable Items with leading numerics",PSSSRT="A":"Dosage report for all Orderable Items",1:"Dosage report for Orderable Items from "_PSSBEG_" through "_PSSEND),?64,"PAGE: "_$G(PSSCT) S PSSCT=PSSCT+1
- W !,PSSLINE
- Q
- SETD ;
- N PSSVA,PSSVA1,PSSVB,PSSVB1,PSSDASH,PSSNDFS,PSSDASH2,PSSDASH3,PSSDASH4,PSSDASH5 K PSSCALC
- S PSSDASH=0 S PSSNDFS=$$PSJST^PSNAPIS(+$P($G(^PSDRUG(PSSIEN,"ND")),"^"),+$P($G(^PSDRUG(PSSIEN,"ND")),"^",3)) S PSSNDFS=+$P($G(PSSNDFS),"^",2) I $G(PSSNDFS),$G(PSSSTR),+$G(PSSSTR)'=+$G(PSSNDFS) S PSSDASH=1
- S PSSVA=$P(PSSUNIT,"/"),PSSVB=$P(PSSUNIT,"/",2),PSSVA1=+$G(PSSVA),PSSVB1=+$G(PSSVB)
- I $G(PSSDASH) S PSSDASH2=PSSSTR/PSSNDFS,PSSDASH3=PSSDASH2*PSSC S PSSDASH4=PSSDASH3*$S($G(PSSVB1):PSSVB1,1:1) S PSSDASH5=$S('$G(PSSVB1):PSSDASH4_$G(PSSVB),1:PSSDASH4_$P(PSSVB,PSSVB1,2))
- S PSSCALC=$S('$G(PSSVA1):PSSD,1:($G(PSSVA1)*PSSD))_$S($G(PSSVA1):$P(PSSVA,PSSVA1,2),1:PSSVA)_"/"_$S($G(PSSDASH):$G(PSSDASH5),'$G(PSSVB1):+$G(PSSC)_$G(PSSVB),1:(+$G(PSSC)*+PSSVB1)_$P(PSSVB,PSSVB1,2))
- Q
- OUT ;
- K PSSDFOI,PSSDFOIN,PSSDF,PSSDZZ
- Q:$G(PSSE)'["O"
- S PSSDFOI=$P($G(^PSDRUG(PSSIEN,2)),"^") Q:'PSSDFOI
- S PSSDF=$P($G(^PS(50.7,+PSSDFOI,0)),"^",2)
- S PSSDFOIN=$P($G(^PS(50.606,+$G(PSSDF),0)),"^")
- Q:'PSSDF
- K PSSDZ F PSSDZZ=0:0 S PSSDZZ=$O(^PS(50.606,PSSDF,"NOUN",PSSDZZ)) Q:'PSSDZZ!($G(PSSDZ)'="") I $P($G(^(PSSDZZ,0)),"^")'="" S PSSDZ=$P($G(^(0)),"^")
- I $G(PSSDZ)="" S PSSDZ=$G(PSSDFOIN)
- I $G(PSSC) D PARN
- W ?94,$G(PSSC)_" "_$S($G(PSSDZN)'="":$G(PSSDZN),1:$G(PSSDZ))
- K PSSDFOI,PSSDF,PSSDZ,PSSDZZ,PSSDZN,PSSDZNX,PSSDFOIN
- Q
- PARN ;
- K PSSDZN,PSSDZNX
- Q:$G(PSSDZ)=""
- Q:$L(PSSDZ)'>3
- S PSSDZNX=$E(PSSDZ,($L(PSSDZ)-2),$L(PSSDZ))
- I $G(PSSDZNX)="(S)"!($G(PSSDZNX)="(s)") D
- .I $G(PSSC)'>1 S PSSDZN=$E(PSSDZ,1,($L(PSSDZ)-3))
- .I $G(PSSC)>1 S PSSDZN=$E(PSSDZ,1,($L(PSSDZ)-3))_$E(PSSDZNX,2)
- Q
- PSSOIDOS ;BIR/RTR-Orderable Item/Dosage review report ;03/24/00
- +1 ;;1.0;PHARMACY DATA MANAGEMENT;**40**;9/30/97
- EN ;
- +1 KILL PSSHOW,PSSBEG,PSSEND,PSSSRT
- +2 KILL DIR
- SET DIR(0)="S^A:ALL;S:SELECT A RANGE"
- SET DIR("B")="S"
- SET DIR("A")="Print Report for (A)ll or (S)elect a Range"
- Begin DoDot:1
- +3 SET DIR("?")=" "
- SET DIR("?",1)="Enter 'A' to run report for all Orderable Items. Enter 'S' to select a range"
- SET DIR("?",2)="(alphabetically) of Orderable Items to print."
- End DoDot:1
- DO ^DIR
- KILL DIR
- IF Y["^"!($DATA(DTOUT))!($DATA(DUOUT))
- WRITE !!,"Nothing queued to print.",!
- GOTO ENDX
- +4 SET PSSHOW=Y
- IF PSSHOW="A"
- SET PSSBEG="A"
- SET PSSEND="Z"
- SET PSSSRT="A"
- GOTO DEV
- +5 ;W !!,"To see drugs beginning with the letter 'A', enter 'A', or whichever letter you",!,"wish to see. To see drugs in a range, for example drugs starting with the",!,"letters 'G', 'H', 'I' and 'J', enter in the format 'G-J'.",!
- ASK ;
- +1 KILL DIR,PSSBEG,PSSEND,PSSNUMBX
- +2 SET PSSNUMB=""
- +3 FOR
- SET PSSNUMB=$ORDER(^PS(50.7,"B",PSSNUMB))
- IF 'PSSNUMB!($GET(PSSNUMBX))
- QUIT
- SET PSSNUMBX=1
- +4 IF $GET(PSSNUMBX)
- KILL DIR
- SET DIR(0)="Y"
- SET DIR("A")="Print report for Orderable Items with leading numerics"
- SET DIR("B")="N"
- Begin DoDot:1
- +5 WRITE !!!,"There are entries in the Orderable Item file with leading numerics.",!
- +6 SET DIR("?")=" "
- SET DIR("?",1)="There are some entries in the Orderable Item file with leading numerics."
- SET DIR("?",2)="Enter Yes to print the report for those drugs."
- SET DIR("?",3)=" "
- End DoDot:1
- DO ^DIR
- KILL DIR
- IF Y["^"!($DATA(DUOUT))!($DATA(DTOUT))
- WRITE !!,"Nothing queued to print.",!
- GOTO ENDX
- +7 IF $GET(PSSNUMBX)
- IF $GET(Y)=1
- SET PSSSRT="N"
- GOTO DEV
- +8 KILL PSSNUMB,PSSNUMBX
- ASKA KILL PSSBEG,PSSEND
- +1 WRITE !!,"To see items beginning with the letter 'A', enter 'A', or whichever letter you",!,"wish to see. To see items in a range, for example items starting with the",!,"letters 'G', 'H', 'I' and 'J', enter in the format 'G-J'.",!
- +2 SET DIR("?",1)=" "
- SET DIR("?",2)="Enter either 1 letter, 'A', 'B', etc., to see items beginning with that letter,"
- SET DIR("?",3)="or to see a range of items enter in the format 'A-C', 'G-M', 'S-Z', etc."
- SET DIR("?",4)=" "
- SET DIR("?")=" "
- +3 SET DIR("A")="Select a Range"
- SET DIR(0)="F^1:3"
- DO ^DIR
- IF Y["^"!($DATA(DTOUT))!($DATA(DUOUT))
- WRITE !!,"Nothing queued to print.",!
- GOTO ENDX
- +4 SET X=Y
- IF X'?1U&(X'?1U1"-"1U)&(X'?1L)&(X'?1L1"-"1L)
- WRITE !!,"Invalid response, enter a letter, 'A', 'B', etc., or a range, 'C-F', 'M-R', etc.",!
- GOTO ASKA
- +5 IF X["-"
- SET PSSBEG=$PIECE(X,"-")
- SET PSSEND=$PIECE(X,"-",2)
- IF $ASCII(PSSEND)<$ASCII(PSSBEG)
- WRITE !!,"Invalid response.",!
- GOTO ASKA
- +6 IF X'["-"
- SET PSSBEG=X
- SET PSSEND=X
- +7 SET PSSSRT="X"
- DEV IF PSSSRT="X"
- WRITE !!,"Report will be for items starting with the letter "_$GET(PSSBEG)_",",!,"and ending with items starting with the letter "_$GET(PSSEND)_".",!
- +1 IF PSSSRT="N"
- WRITE !!,"This report will be for items with leading numerics.",!
- +2 IF PSSSRT="A"
- WRITE !!,"This report will be for all items.",!
- +3 KILL DIR
- SET DIR(0)="Y"
- SET DIR("A")="Is this correct"
- SET DIR("B")="Y"
- DO ^DIR
- KILL DIR
- IF Y'=1
- WRITE !
- GOTO EN
- +4 ;W $C(7),!!?3,"This report is designed for 132 column format!",!
- +5 WRITE !
- KILL IOP,%ZIS,POP
- SET %ZIS="QM"
- DO ^%ZIS
- IF $GET(POP)
- WRITE !!,"Nothing queued to print.",!
- GOTO ENDX
- +6 IF $DATA(IO("Q"))
- SET ZTRTN="START^PSSOIDOS"
- SET ZTDESC="Orderable Item/Dosages Review Report"
- SET ZTSAVE("PSSHOW")=""
- SET ZTSAVE("PSSBEG")=""
- SET ZTSAVE("PSSEND")=""
- SET ZTSAVE("PSSSRT")=""
- DO ^%ZTLOAD
- KILL %ZIS
- WRITE !,"Report queued to print.",!
- GOTO ENDX
- START ;
- +1 USE IO
- +2 IF '$GET(DT)
- SET DT=$$DT^XLFDT
- +3 SET X1=DT
- SET X2=-365
- DO C^%DTC
- SET PSSYEAR=$GET(X)
- KILL X,X1,X2
- +4 SET PSSOUT=0
- SET PSSDV=$SELECT($EXTRACT(IOST)="C":"C",1:"P")
- SET PSSCT=1
- +5 KILL PSSLINE,PSSIEND
- SET $PIECE(PSSLINE,"-",78)=""
- +6 DO HD
- +7 IF PSSSRT="N"
- GOTO PASS
- +8 SET PSSX=$ASCII(PSSBEG)-1
- +9 SET PSSNAME=$CHAR(PSSX)_"zzzz"
- PASS ;
- +1 IF $GET(PSSSRT)="N"
- SET (PSSNAME,PSSEND)=""
- +2 IF $GET(PSSSRT)="A"
- SET (PSSNAME,PSSEND)=""
- +3 FOR
- SET PSSNAME=$ORDER(^PS(50.7,"ADF",PSSNAME))
- IF $SELECT(PSSSRT="N"&('PSSNAME)
- QUIT
- Begin DoDot:1
- +4 FOR PSSIEND=0:0
- SET PSSIEND=$ORDER(^PS(50.7,"ADF",PSSNAME,PSSIEND))
- IF 'PSSIEND!($GET(PSSOUT))
- QUIT
- FOR PSSIEN=0:0
- SET PSSIEN=$ORDER(^PS(50.7,"ADF",PSSNAME,PSSIEND,PSSIEN))
- IF 'PSSIEN!($GET(PSSOUT))
- QUIT
- Begin DoDot:2
- +5 IF '$DATA(^PS(50.7,PSSIEN,0))
- QUIT
- +6 IF $PIECE($GET(^PS(50.7,PSSIEN,0)),"^",3)
- QUIT
- +7 IF ($Y+5)>IOSL
- DO HD
- IF $GET(PSSOUT)
- QUIT
- +8 KILL PSSINA,PSSNF,PSSINAD,PSSUNIT,PSSAPU
- SET PSSINA=$PIECE($GET(^PS(50.7,PSSIEN,0)),"^",4)
- +9 IF $GET(PSSINA)
- IF $GET(PSSYEAR)
- IF $GET(PSSINA)<$GET(PSSYEAR)
- QUIT
- +10 IF $GET(PSSINA)
- SET PSSINAD=$EXTRACT(PSSINA,4,5)_"/"_$EXTRACT(PSSINA,6,7)_"/"_$EXTRACT(PSSINA,2,3)
- +11 SET PSSLEN=$PIECE($GET(^PS(50.7,PSSIEN,0)),"^")_" "_$PIECE($GET(^PS(50.606,+$PIECE($GET(^PS(50.7,PSSIEN,0)),"^",2),0)),"^")
- +12 WRITE !!,$GET(PSSLEN)
- +13 IF ($Y+5)>IOSL
- DO HD
- IF $GET(PSSOUT)
- QUIT
- +14 IF $GET(PSSINA)
- Begin DoDot:3
- +15 IF $LENGTH(PSSLEN)>62
- WRITE !,?64,$GET(PSSINAD)
- QUIT
- +16 WRITE ?64,$GET(PSSINAD)
- End DoDot:3
- +17 IF ($Y+5)>IOSL
- DO HD
- IF $GET(PSSOUT)
- QUIT
- +18 KILL PSSINP,PSSINPZ
- DO DOSE^PSSORUTZ(.PSSINP,PSSIEN,"U")
- Begin DoDot:3
- +19 IF '$ORDER(PSSINP(0))
- QUIT
- +20 WRITE !?2,"Inpatient Dosages:"
- +21 FOR PSSINPX=0:0
- SET PSSINPX=$ORDER(PSSINP(PSSINPX))
- IF 'PSSINPX!($GET(PSSOUT))
- QUIT
- Begin DoDot:4
- +22 IF ($Y+5)>IOSL
- DO HD
- IF $GET(PSSOUT)
- QUIT
- +23 SET PSSLZ=$PIECE($GET(PSSINP(PSSINPX)),"^",5)
- WRITE !?4,PSSLZ
- +24 IF $LENGTH(PSSLZ)>32
- WRITE !
- +25 WRITE ?38,$PIECE($GET(PSSINP("DD",+$PIECE($GET(PSSINP(PSSINPX)),"^",6))),"^")
- End DoDot:4
- End DoDot:3
- +26 IF $GET(PSSOUT)
- QUIT
- +27 KILL PSSOUP,PSSOUPZ,PSSLZZZ
- DO DOSE^PSSORUTZ(.PSSOUP,PSSIEN,"O")
- Begin DoDot:3
- +28 IF '$ORDER(PSSOUP(0))
- QUIT
- +29 WRITE !?2,"Outpatient Dosages:"
- +30 FOR PSSOUPX=0:0
- SET PSSOUPX=$ORDER(PSSOUP(PSSOUPX))
- IF 'PSSOUPX!($GET(PSSOUT))
- QUIT
- Begin DoDot:4
- +31 IF ($Y+5)>IOSL
- DO HD
- IF $GET(PSSOUT)
- QUIT
- +32 SET PSSLZ=$PIECE($GET(PSSOUP(PSSOUPX)),"^",5)
- WRITE !?4,PSSLZ
- +33 KILL PSSLZZZ
- IF $PIECE($GET(PSSOUP(PSSOUPX)),"^")'=""
- SET PSSLZZZ="("_$PIECE($GET(PSSOUP(PSSOUPX)),"^",3)_" "_$PIECE($GET(PSSOUP(PSSOUPX)),"^",4)_")"
- +34 IF $SELECT($LENGTH(PSSLZ)>10&($GET(PSSLZZZ)'=""):1,$LENGTH(PSSLZ)>32:1,1:0)
- WRITE !
- +35 IF $GET(PSSLZZZ)'=""
- WRITE ?16,$GET(PSSLZZZ)
- IF $LENGTH(PSSLZZZ)>20
- WRITE !
- +36 WRITE ?38,$PIECE($GET(PSSOUP("DD",+$PIECE($GET(PSSOUP(PSSOUPX)),"^",6))),"^")
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- END ;
- +1 IF '$GET(PSSOUT)
- IF $GET(PSSDV)="C"
- WRITE !!,"End of Report."
- KILL DIR
- SET DIR(0)="E"
- SET DIR("A")="Press Return to continue"
- DO ^DIR
- KILL DIR
- +2 IF $GET(PSSDV)="C"
- WRITE !
- +3 IF '$TEST
- WRITE @IOF
- ENDX KILL PSSOUP,PSSOUPX,PSSINP,PSSINPX,PSSOUPZ,PSSINPZ,PSSLZ,PSSLZZZ
- +1 KILL PSSNODE,PSSLEN,PSSIEND,PSSNUMB,PSSNUMBX,PSSSRT,PSSCALC,PSSSTR,PSSUNIT,PSSIEN,PSSINAD,PSSINA,PSSNF,PSSNAME,PSSDV,PSSX,PSSOUT,PSSHOW,PSSBEG,PSSLINE,PSSEND,PSSA,PSSB,PSSC,PSSD,PSSE,PSSAPU,PSSMSG,PSSYEAR
- DO ^%ZISC
- IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +2 QUIT
- HD ;
- +1 IF $GET(PSSDV)="C"
- IF $GET(PSSCT)'=1
- WRITE !
- KILL DIR
- SET DIR(0)="E"
- SET DIR("A")="Press Return to continue, '^' to exit"
- DO ^DIR
- KILL DIR
- IF 'Y
- SET PSSOUT=1
- QUIT
- +2 WRITE @IOF
- WRITE !,$SELECT(PSSSRT="N":"Dosage report for Orderable Items with leading numerics",PSSSRT="A":"Dosage report for all Orderable Items",1:"Dosage report for Orderable Items from "_PSSBEG_" through "_PSSEND),?64,"PAGE: "_$GET(PSSCT)
- SET PSSCT=PSSCT+1
- +3 WRITE !,PSSLINE
- +4 QUIT
- SETD ;
- +1 NEW PSSVA,PSSVA1,PSSVB,PSSVB1,PSSDASH,PSSNDFS,PSSDASH2,PSSDASH3,PSSDASH4,PSSDASH5
- KILL PSSCALC
- +2 SET PSSDASH=0
- SET PSSNDFS=$$PSJST^PSNAPIS(+$PIECE($GET(^PSDRUG(PSSIEN,"ND")),"^"),+$PIECE($GET(^PSDRUG(PSSIEN,"ND")),"^",3))
- SET PSSNDFS=+$PIECE($GET(PSSNDFS),"^",2)
- IF $GET(PSSNDFS)
- IF $GET(PSSSTR)
- IF +$GET(PSSSTR)'=+$GET(PSSNDFS)
- SET PSSDASH=1
- +3 SET PSSVA=$PIECE(PSSUNIT,"/")
- SET PSSVB=$PIECE(PSSUNIT,"/",2)
- SET PSSVA1=+$GET(PSSVA)
- SET PSSVB1=+$GET(PSSVB)
- +4 IF $GET(PSSDASH)
- SET PSSDASH2=PSSSTR/PSSNDFS
- SET PSSDASH3=PSSDASH2*PSSC
- SET PSSDASH4=PSSDASH3*$SELECT($GET(PSSVB1):PSSVB1,1:1)
- SET PSSDASH5=$SELECT('$GET(PSSVB1):PSSDASH4_$GET(PSSVB),1:PSSDASH4_$PIECE(PSSVB,PSSVB1,2))
- +5 SET PSSCALC=$SELECT('$GET(PSSVA1):PSSD,1:($GET(PSSVA1)*PSSD))_$SELECT($GET(PSSVA1):$PIECE(PSSVA,PSSVA1,2),1:PSSVA)_"/"_$SELECT($GET(PSSDASH):$GET(PSSDASH5),'$GET(PSSVB1):+$GET(PSSC)_$GET(PSSVB),1:(+$GET(PSSC)*+PSSVB1)_$PIECE(PSSVB,PSSVB1,2))
- +6 QUIT
- OUT ;
- +1 KILL PSSDFOI,PSSDFOIN,PSSDF,PSSDZZ
- +2 IF $GET(PSSE)'["O"
- QUIT
- +3 SET PSSDFOI=$PIECE($GET(^PSDRUG(PSSIEN,2)),"^")
- IF 'PSSDFOI
- QUIT
- +4 SET PSSDF=$PIECE($GET(^PS(50.7,+PSSDFOI,0)),"^",2)
- +5 SET PSSDFOIN=$PIECE($GET(^PS(50.606,+$GET(PSSDF),0)),"^")
- +6 IF 'PSSDF
- QUIT
- +7 KILL PSSDZ
- FOR PSSDZZ=0:0
- SET PSSDZZ=$ORDER(^PS(50.606,PSSDF,"NOUN",PSSDZZ))
- IF 'PSSDZZ!($GET(PSSDZ)'="")
- QUIT
- IF $PIECE($GET(^(PSSDZZ,0)),"^")'=""
- SET PSSDZ=$PIECE($GET(^(0)),"^")
- +8 IF $GET(PSSDZ)=""
- SET PSSDZ=$GET(PSSDFOIN)
- +9 IF $GET(PSSC)
- DO PARN
- +10 WRITE ?94,$GET(PSSC)_" "_$SELECT($GET(PSSDZN)'="":$GET(PSSDZN),1:$GET(PSSDZ))
- +11 KILL PSSDFOI,PSSDF,PSSDZ,PSSDZZ,PSSDZN,PSSDZNX,PSSDFOIN
- +12 QUIT
- PARN ;
- +1 KILL PSSDZN,PSSDZNX
- +2 IF $GET(PSSDZ)=""
- QUIT
- +3 IF $LENGTH(PSSDZ)'>3
- QUIT
- +4 SET PSSDZNX=$EXTRACT(PSSDZ,($LENGTH(PSSDZ)-2),$LENGTH(PSSDZ))
- +5 IF $GET(PSSDZNX)="(S)"!($GET(PSSDZNX)="(s)")
- Begin DoDot:1
- +6 IF $GET(PSSC)'>1
- SET PSSDZN=$EXTRACT(PSSDZ,1,($LENGTH(PSSDZ)-3))
- +7 IF $GET(PSSC)>1
- SET PSSDZN=$EXTRACT(PSSDZ,1,($LENGTH(PSSDZ)-3))_$EXTRACT(PSSDZNX,2)
- End DoDot:1
- +8 QUIT
