PSSREMCH ;BIR/RTR-Pre release Orderable Item report ;02/14/00
;;1.0;PHARMACY DATA MANAGEMENT;**34**;9/30/97
S PSSOUT=0 D TEXT^PSSUTLPR I $G(PSSOUT) K PSSOUT Q
G ADDRP^PSSUTLPR
ADD ;
N AAZ,AAZZ,SSZ,SSZZ,PSSATMP,PSSSTMP
U IO S PSSOUT=0 K PSSADSUM,PSSTOTAL,PSSIVID,PSSIVIDL,PSSSOSUM
S PSSDV=$S($E(IOST)="C":"C",1:"P"),PSSCOT=1
S PSSIVID=$S($P($G(^PS(59.7,1,31)),"^",2)'="":$P($G(^(31)),"^",2),1:"IV") S PSSIVIDL=$L(PSSIVID)
I $G(PSSTYPE)="S" G SOL
S PSSWH="A"
N ADD,AA,OI,PAD,ADDIEN,ZERO,LEN,COUNT,PSSAD,PAA,PZZ,PDD,OINAME,OIDOSE,OILT,TOTAL,PSSPADZ,AOILT,NEWOI,NEWOIL,ADDLT,PSSADIN,PSSADID,OIDATE,OIDATED,PSSPADX,PSSPADZZ,OIZD,OIZDZ,PSINDAT,PSINDATE
K ^TMP($J,"PSSAD")
D ADDH
S ADD="" F S ADD=$O(^PS(52.6,"B",ADD)) Q:ADD=""!($G(PSSOUT)) F ADDIEN=0:0 S ADDIEN=$O(^PS(52.6,"B",ADD,ADDIEN)) Q:'ADDIEN!($G(PSSOUT)) D
.Q:'$P($G(^PS(52.6,ADDIEN,0)),"^",11)
.S ZERO=$G(^PS(52.6,ADDIEN,0)),LEN=$L($P(ZERO,"^"))
.K PSSADID S PSSADIN=$P($G(^PS(52.6,ADDIEN,"I")),"^") I PSSADIN S PSSADID="("_$E(PSSADIN,4,5)_"/"_$E(PSSADIN,6,7)_"/"_$E(PSSADIN,2,3)_")"
.S LEN=LEN+$S($G(PSSADID)'="":11,1:0)
.K PAD S $P(PAD,"=",(42-LEN))="",PAD=$G(PAD)_"> "
.S OINAME=$P($G(^PS(50.7,+$P(ZERO,"^",11),0)),"^"),OIDOSE=$P($G(^PS(50.606,+$P($G(^(0)),"^",2),0)),"^"),OILT=$L($G(OINAME))+$L($G(OIDOSE))+2
.K OIDATED S OIDATE=$P($G(^PS(50.7,+$P(ZERO,"^",11),0)),"^",4) I OIDATE S OIDATED="("_$E(OIDATE,4,5)_"/"_$E(OIDATE,6,7)_"/"_$E(OIDATE,2,3)_")"
.S ADDLT=$L(ADDIEN)+3
.S PSSTOTAL=+$G(ADDLT)+45+$G(OILT)+$S($G(OIDATED)'="":11,1:0)+$G(PSSIVIDL)
.S PSSPADZ=+$G(ADDLT)+42
.I ($Y+5)>IOSL D ADDH Q:$G(PSSOUT)
.W !!,?3,"Current Additive/Orderable Item match:",!
.I $G(PSSTOTAL)<132 W "("_$G(ADDIEN)_") "_$P(ZERO,"^")_$S($G(PSSADID)'="":" "_$G(PSSADID),1:"")_$G(PAD)_$G(OINAME)_" "_$G(OIDOSE)_$S($G(OIDATED)'="":" "_$G(OIDATED),1:"")_" "_$G(PSSIVID)
.I $G(PSSTOTAL)>131 W "("_$G(ADDIEN)_") "_$P(ZERO,"^")_$S($G(PSSADID)'="":" "_$G(PSSADID),1:"")_$G(PAD) W !,"=====> ",$G(OINAME)_" "_$G(OIDOSE)_$S($G(OIDATED)'="":" "_$G(OIDATED),1:"")_" "_$G(PSSIVID)
.S OI=$P($G(^PSDRUG(+$P(ZERO,"^",2),2)),"^") I 'OI W !?5,"cannot re-match, no Orderable Item for the Dispense Drug" Q
.S PSSATMP=$P($G(^PS(50.7,OI,0)),"^")_" "_$P($G(^PS(50.606,+$P($G(^(0)),"^",2),0)),"^")
.S ^TMP($J,"PSSAD",PSSATMP,ADDIEN)=OI
.S NEWOI=$P($G(^PS(50.7,+$G(OI),0)),"^")_" "_$P($G(^PS(50.606,+$P($G(^(0)),"^",2),0)),"^")
.K OIZDZ S OIZD=$P($G(^PS(50.7,+$G(OI),0)),"^",4) I OIZD S OIZDZ="("_$E(OIZD,4,5)_"/"_$E(OIZD,6,7)_"/"_$E(OIZD,2,3)_")"
.K PSSPADZZ S PSSPADX=$G(PSSPADZ)-18 S $P(PSSPADZZ,"=",PSSPADX)=""
.S PSSPADZZ=PSSPADZZ_"> "
.W !,"New Orderable Item"_$G(PSSPADZZ)_$G(NEWOI)_$S($G(OIZDZ)'="":" "_$G(OIZDZ),1:"")
.W !?2,"Dispense Drugs matched to Orderable Item:"
.F PAA=0:0 S PAA=$O(^PSDRUG("ASP",OI,PAA)) Q:'PAA!($G(PSSOUT)) D
..I ($Y+4)>IOSL D ADDH Q:$G(PSSOUT)
..K PSINDATE S PSINDAT=$P($G(^PSDRUG(PAA,"I")),"^") I PSINDAT S PSINDATE=" "_"("_$E(PSINDAT,4,5)_"/"_$E(PSINDAT,6,7)_"/"_$E(PSINDAT,2,3)_")"
..I PSINDAT,PSINDAT<$G(PSSYRX) Q
..W !?4,$P($G(^PSDRUG(PAA,0)),"^")_$G(PSINDATE) I PAA=$P(ZERO,"^",2) W ?55,"(Additive link)"
I $G(PSSOUT) G ADDX
D ADDHS G:$G(PSSOUT) ADDX
S PSSADSUM=1
S AA="" F S AA=$O(^TMP($J,"PSSAD",AA)) Q:AA=""!($G(PSSOUT)) D
.S AAZ=$O(^TMP($J,"PSSAD",AA,0)),AAZZ=+$G(^TMP($J,"PSSAD",AA,+$G(AAZ)))
.I ($Y+4)>IOSL D ADDH Q:$G(PSSOUT)
.W !!,"OI => ",AA_$S($P($G(^PS(50.7,AAZZ,0)),"^",4)="":"",1:" ("_$E($P($G(^(0)),"^",4),4,5)_"/"_$E($P($G(^(0)),"^",4),6,7)_"/"_$E($P($G(^(0)),"^",4),2,3)_")")
.F PZZ=0:0 S PZZ=$O(^TMP($J,"PSSAD",AA,PZZ)) Q:'PZZ!($G(PSSOUT)) D
..I ($Y+4)>IOSL D ADDH Q:$G(PSSOUT)
..W !,"("_$G(PZZ)_") ",?13,$P($G(^PS(52.6,PZZ,0)),"^")_$S($P($G(^("I")),"^")="":"",1:" ("_$E($P($G(^("I")),"^"),4,5)_"/"_$E($P($G(^("I")),"^"),6,7)_"/"_$E($P($G(^("I")),"^"),2,3)_")"),?69,"(Additive)"
.Q:$G(PSSOUT)
.W !?2,"Dispense Drugs matched to OI:"
.F PDD=0:0 S PDD=$O(^PSDRUG("ASP",AAZZ,PDD)) Q:'PDD!($G(PSSOUT)) D
..I ($Y+4)>IOSL D ADDH Q:$G(PSSOUT)
..I $P($G(^PSDRUG(PDD,"I")),"^"),$P($G(^("I")),"^")<$G(PSSYRX) Q
..W !,?11,$P($G(^PSDRUG(PDD,0)),"^")_$S($P($G(^("I")),"^")="":"",1:" ("_$E($P($G(^("I")),"^"),4,5)_"/"_$E($P($G(^("I")),"^"),6,7)_"/"_$E($P($G(^("I")),"^"),2,3)_")")
ADDX ;
K ^TMP($J,"PSSAD")
I $G(PSSTYPE)="B",'$G(PSSOUT) G SOL
I '$G(PSSOUT) D PDIR
G END
SOL ;
K ^TMP($J,"PSSOL"),PSSCOTX
S PSSWH="S"
N SOL,SLDD,SZZ,SOLAA,SAA,SOLIEN,SNAME,SLNEWOI,SOINAME,SOIDOSE,SOILT,SOILTX,STOTAL,SLOI,SDA,SDAT,SDOI,SDOID,SOLLT,PSSSOLZ,SOIZD,SOIZDZ,SZL,SZLA,SLID,SLIDD
D SOLH S PSSCOTX=1
I $G(PSSOUT) G SEND
S SOL="" F S SOL=$O(^PS(52.7,"B",SOL)) Q:SOL=""!($G(PSSOUT)) F SOLIEN=0:0 S SOLIEN=$O(^PS(52.7,"B",SOL,SOLIEN)) Q:'SOLIEN!($G(PSSOUT)) D
.Q:'$P($G(^PS(52.7,SOLIEN,0)),"^",11)
.S ZERO=$G(^PS(52.7,SOLIEN,0))
.S SNAME=$P(ZERO,"^")_" ("_$P(ZERO,"^",3)_")",LEN=$L(SNAME)
.K SDAT S SDA=$P($G(^PS(52.7,SOLIEN,"I")),"^") I SDA S SDAT="("_$E(SDA,4,5)_"/"_$E(SDA,6,7)_"/"_$E(SDA,2,3)_")"
.S LEN=LEN+$S($G(SDAT)'="":11,1:0)
.K PAD S $P(PAD,"=",(53-LEN))="",PAD=$G(PAD)_"> "
.S SOINAME=$P($G(^PS(50.7,+$P(ZERO,"^",11),0)),"^"),SOIDOSE=$P($G(^PS(50.606,+$P($G(^(0)),"^",2),0)),"^"),SOILT=$L($G(SOINAME))+$L($G(SOIDOSE))+2
.K SDOID S SDOI=$P($G(^PS(50.7,+$P(ZERO,"^",11),0)),"^",4) I SDOI S SDOID="("_$E(SDOI,4,5)_"/"_$E(SDOI,6,7)_"/"_$E(SDOI,2,3)_")"
.S SOLLT=$L(SOLIEN)+3
.S PSSTOTAL=+$G(SOLLT)+67+$G(SOILT)+$S($G(PDOID)'="":11,1:0)+$G(PSSIVIDL)
.S PSSSOLZ=+$G(SOLLT)+53
.I ($Y+5)>IOSL D SOLH Q:$G(PSSOUT)
.W !!?3,"Current Solution/Orderable Item match:",!
.I $G(PSSTOTAL)<132 W "("_$G(SOLIEN)_") "_$G(SNAME)_$S($G(SDAT)'="":" "_$G(SDAT),1:"")_$G(PAD)_$G(SOINAME)_" "_$G(SOIDOSE)_$S($G(SDOID)'="":" "_$G(SDOID),1:"")_" "_$G(PSSIVID)
.I $G(PSSTOTAL)>131 W "("_$G(SOLIEN)_") "_$G(SNAME)_$S($G(SDAT)'="":" "_$G(SDAT),1:"")_$G(PAD) D:($Y+4)>IOSL SOLH Q:$G(PSSOUT) W !,"=====> ",$G(SOINAME)_" "_$G(SOIDOSE)_$S($G(SDOID)'="":" "_$G(SDOID),1:"")_" "_$G(PSSIVID)
.S SLOI=$P($G(^PSDRUG(+$P(ZERO,"^",2),2)),"^") I 'SLOI W !?5,"cannot rematch, no Item for the Dispense Drug" Q
.S PSSSTMP=$P($G(^PS(50.7,+$G(SLOI),0)),"^")_" "_$P($G(^PS(50.606,+$P($G(^(0)),"^",2),0)),"^")
.S ^TMP($J,"PSSOL",PSSSTMP,SOLIEN)=SLOI
.S SLNEWOI=$P($G(^PS(50.7,+$G(SLOI),0)),"^")_" "_$P($G(^PS(50.606,+$P($G(^(0)),"^",2),0)),"^")
.K SOIZDZ S SOIZD=$P($G(^PS(50.7,+$G(SLOI),0)),"^",4) I SOIZD S SOIZDZ="("_$E(SOIZD,4,5)_"/"_$E(SOIZD,6,7)_"/"_$E(SOIZD,2,3)_")"
.K SZL S SZLA=$G(PSSSOLZ)-18 S $P(SZL,"=",SZLA)="" S SZL=SZL_"> "
.W !,"New Orderable Item"_$G(SZL)_$G(SLNEWOI)_$S($G(SOIZDZ)'="":" "_$G(SOIZDZ),1:"")
.W !?2,"Dispense Drugs matched to Orderable Item:"
.F SAA=0:0 S SAA=$O(^PSDRUG("ASP",SLOI,SAA)) Q:'SAA!($G(PSSOUT)) D
..I ($Y+4)>IOSL D SOLH Q:$G(PSSOUT)
..K SLID S SLIDD=$P($G(^PSDRUG(SAA,"I")),"^") I SLIDD S SLID=" "_"("_$E(SLIDD,4,5)_"/"_$E(SLIDD,6,7)_"/"_$E(SLIDD,2,3)_")"
..I SLIDD,SLIDD<$G(PSSYRX) Q
..W !?4,$P($G(^PSDRUG(SAA,0)),"^")_$G(SLID) I SAA=$P(ZERO,"^",2) W ?59,"(Solution link)"
I $G(PSSOUT) G SEND
D SOLHS G:$G(PSSOUT) SEND
S PSSSOSUM=1
S SOLAA="" F S SOLAA=$O(^TMP($J,"PSSOL",SOLAA)) Q:SOLAA=""!($G(PSSOUT)) D
.S SSZ=$O(^TMP($J,"PSSOL",SOLAA,0)),SSZZ=+$G(^TMP($J,"PSSOL",SOLAA,+$G(SSZ)))
.I ($Y+4)>IOSL D SOLH Q:$G(PSSOUT)
.W !!,"OI => ",SOLAA_$S($P($G(^PS(50.7,SSZZ,0)),"^",4)="":"",1:" ("_$E($P($G(^(0)),"^",4),4,5)_"/"_$E($P($G(^(0)),"^",4),6,7)_"/"_$E($P($G(^(0)),"^",4),2,3)_")")
.F SZZ=0:0 S SZZ=$O(^TMP($J,"PSSOL",SOLAA,SZZ)) Q:'SZZ!($G(PSSOUT)) D
..I ($Y+4)>IOSL D SOLH Q:$G(PSSOUT)
..W !,"("_$G(SZZ)_") ",?13,$P($G(^PS(52.7,SZZ,0)),"^")_" ("_$P($G(^(0)),"^",3)_")"_$S($P($G(^("I")),"^")="":"",1:" ("_$E($P($G(^("I")),"^"),4,5)_"/"_$E($P($G(^("I")),"^"),6,7)_"/"_$E($P($G(^("I")),"^"),2,3)_")") W ?67,"(Solution)"
.Q:$G(PSSOUT)
.W !?2,"Dispense Drugs matched to OI:"
.F SLDD=0:0 S SLDD=$O(^PSDRUG("ASP",SSZZ,SLDD)) Q:'SLDD!($G(PSSOUT)) D
..I ($Y+4)>IOSL D SOLH Q:$G(PSSOUT)
..I $P($G(^PSDRUG(SLDD,"I")),"^"),$P($G(^("I")),"^")<$G(PSSYRX) Q
..W !?11,$P($G(^PSDRUG(SLDD,0)),"^")_$S($P($G(^("I")),"^")="":"",1:" ("_$E($P($G(^("I")),"^"),4,5)_"/"_$E($P($G(^("I")),"^"),6,7)_"/"_$E($P($G(^("I")),"^"),2,3)_")")
I '$G(PSSOUT) D PDIR
SEND ;
K ^TMP($J,"PSSOL")
END I $G(PSSDV)="C" W !
E W @IOF
K PSSTOTAL,PSSIVID,PSSIVIDL,PSSTYPE,PSSDV,PSSWH,PSSCOT,PSSOUT,PSSCOTX,PSSADSUM,PSSSOSUM,PSSYRX
D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" Q
ADDH ;
I $G(PSSCOT)=1 W @IOF W !?5,"ADDITIVE REPORT (Additive Internal number in parenthesis)",?67,"PAGE: "_$G(PSSCOT) S PSSCOT=PSSCOT+1 Q
I $G(PSSDV)="C" 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 !?8,"ADDITIVE "_$S('$G(PSSADSUM):"REPORT",1:"SUMMARY")_" (continued)" W ?67,"PAGE: "_$G(PSSCOT) S PSSCOT=PSSCOT+1
Q
ADDHS ;
I $G(PSSDV)="C" 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 !!?5,"ADDITIVE SUMMARY" W ?67,"PAGE: "_$G(PSSCOT) S PSSCOT=PSSCOT+1
Q
SOLH ;
I '$G(PSSCOTX) D Q:$G(PSSOUT) W @IOF W !?5,"SOLUTION REPORT (Solution Internal number in parenthesis)",?67,"PAGE: "_$G(PSSCOT) S PSSCOT=PSSCOT+1 Q
.I $G(PSSDV)="C",$G(PSSCOT)'=1 K DIR S DIR(0)="E",DIR("A")="Press Return to continue, '^' to exit" D ^DIR K DIR I 'Y S PSSOUT=1
I $G(PSSDV)="C" 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 !?8,"SOLUTION "_$S('$G(PSSSOSUM):"REPORT",1:"SUMMARY")_" (continued)" W ?67,"PAGE: "_$G(PSSCOT) S PSSCOT=PSSCOT+1
Q
SOLHS ;
I $G(PSSDV)="C" 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 !!?5,"SOLUTION SUMMARY" W ?67,"PAGE: "_$G(PSSCOT) S PSSCOT=PSSCOT+1
Q
PDIR ;
Q:$G(PSSDV)'="C"
W ! S DIR(0)="E",DIR("A")="Pres Return to continue, '^' to exit" D ^DIR K DIR I 'Y S PSSOUT=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSREMCH 9921 printed Nov 22, 2024@17:44:19 Page 2
PSSREMCH ;BIR/RTR-Pre release Orderable Item report ;02/14/00
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**34**;9/30/97
+2 SET PSSOUT=0
DO TEXT^PSSUTLPR
IF $GET(PSSOUT)
KILL PSSOUT
QUIT
+3 GOTO ADDRP^PSSUTLPR
ADD ;
+1 NEW AAZ,AAZZ,SSZ,SSZZ,PSSATMP,PSSSTMP
+2 USE IO
SET PSSOUT=0
KILL PSSADSUM,PSSTOTAL,PSSIVID,PSSIVIDL,PSSSOSUM
+3 SET PSSDV=$SELECT($EXTRACT(IOST)="C":"C",1:"P")
SET PSSCOT=1
+4 SET PSSIVID=$SELECT($PIECE($GET(^PS(59.7,1,31)),"^",2)'="":$PIECE($GET(^(31)),"^",2),1:"IV")
SET PSSIVIDL=$LENGTH(PSSIVID)
+5 IF $GET(PSSTYPE)="S"
GOTO SOL
+6 SET PSSWH="A"
+7 NEW ADD,AA,OI,PAD,ADDIEN,ZERO,LEN,COUNT,PSSAD,PAA,PZZ,PDD,OINAME,OIDOSE,OILT,TOTAL,PSSPADZ,AOILT,NEWOI,NEWOIL,ADDLT,PSSADIN,PSSADID,OIDATE,OIDATED,PSSPADX,PSSPADZZ,OIZD,OIZDZ,PSINDAT,PSINDATE
+8 KILL ^TMP($JOB,"PSSAD")
+9 DO ADDH
+10 SET ADD=""
FOR
SET ADD=$ORDER(^PS(52.6,"B",ADD))
if ADD=""!($GET(PSSOUT))
QUIT
FOR ADDIEN=0:0
SET ADDIEN=$ORDER(^PS(52.6,"B",ADD,ADDIEN))
if 'ADDIEN!($GET(PSSOUT))
QUIT
Begin DoDot:1
+11 if '$PIECE($GET(^PS(52.6,ADDIEN,0)),"^",11)
QUIT
+12 SET ZERO=$GET(^PS(52.6,ADDIEN,0))
SET LEN=$LENGTH($PIECE(ZERO,"^"))
+13 KILL PSSADID
SET PSSADIN=$PIECE($GET(^PS(52.6,ADDIEN,"I")),"^")
IF PSSADIN
SET PSSADID="("_$EXTRACT(PSSADIN,4,5)_"/"_$EXTRACT(PSSADIN,6,7)_"/"_$EXTRACT(PSSADIN,2,3)_")"
+14 SET LEN=LEN+$SELECT($GET(PSSADID)'="":11,1:0)
+15 KILL PAD
SET $PIECE(PAD,"=",(42-LEN))=""
SET PAD=$GET(PAD)_"> "
+16 SET OINAME=$PIECE($GET(^PS(50.7,+$PIECE(ZERO,"^",11),0)),"^")
SET OIDOSE=$PIECE($GET(^PS(50.606,+$PIECE($GET(^(0)),"^",2),0)),"^")
SET OILT=$LENGTH($GET(OINAME))+$LENGTH($GET(OIDOSE))+2
+17 KILL OIDATED
SET OIDATE=$PIECE($GET(^PS(50.7,+$PIECE(ZERO,"^",11),0)),"^",4)
IF OIDATE
SET OIDATED="("_$EXTRACT(OIDATE,4,5)_"/"_$EXTRACT(OIDATE,6,7)_"/"_$EXTRACT(OIDATE,2,3)_")"
+18 SET ADDLT=$LENGTH(ADDIEN)+3
+19 SET PSSTOTAL=+$GET(ADDLT)+45+$GET(OILT)+$SELECT($GET(OIDATED)'="":11,1:0)+$GET(PSSIVIDL)
+20 SET PSSPADZ=+$GET(ADDLT)+42
+21 IF ($Y+5)>IOSL
DO ADDH
if $GET(PSSOUT)
QUIT
+22 WRITE !!,?3,"Current Additive/Orderable Item match:",!
+23 IF $GET(PSSTOTAL)<132
WRITE "("_$GET(ADDIEN)_") "_$PIECE(ZERO,"^")_$SELECT($GET(PSSADID)'="":" "_$GET(PSSADID),1:"")_$GET(PAD)_$GET(OINAME)_" "_$GET(OIDOSE)_$SELECT($GET(OIDATED)'="":" "_$GET(OIDATED),1:"")_" "_$GET(PSSIVID)
+24 IF $GET(PSSTOTAL)>131
WRITE "("_$GET(ADDIEN)_") "_$PIECE(ZERO,"^")_$SELECT($GET(PSSADID)'="":" "_$GET(PSSADID),1:"")_$GET(PAD)
WRITE !,"=====> ",$GET(OINAME)_" "_$GET(OIDOSE)_$SELECT($GET(OIDATED)'="":" "_$GET(OIDATED),1:"")_" "_$GET(PSSIVID)
+25 SET OI=$PIECE($GET(^PSDRUG(+$PIECE(ZERO,"^",2),2)),"^")
IF 'OI
WRITE !?5,"cannot re-match, no Orderable Item for the Dispense Drug"
QUIT
+26 SET PSSATMP=$PIECE($GET(^PS(50.7,OI,0)),"^")_" "_$PIECE($GET(^PS(50.606,+$PIECE($GET(^(0)),"^",2),0)),"^")
+27 SET ^TMP($JOB,"PSSAD",PSSATMP,ADDIEN)=OI
+28 SET NEWOI=$PIECE($GET(^PS(50.7,+$GET(OI),0)),"^")_" "_$PIECE($GET(^PS(50.606,+$PIECE($GET(^(0)),"^",2),0)),"^")
+29 KILL OIZDZ
SET OIZD=$PIECE($GET(^PS(50.7,+$GET(OI),0)),"^",4)
IF OIZD
SET OIZDZ="("_$EXTRACT(OIZD,4,5)_"/"_$EXTRACT(OIZD,6,7)_"/"_$EXTRACT(OIZD,2,3)_")"
+30 KILL PSSPADZZ
SET PSSPADX=$GET(PSSPADZ)-18
SET $PIECE(PSSPADZZ,"=",PSSPADX)=""
+31 SET PSSPADZZ=PSSPADZZ_"> "
+32 WRITE !,"New Orderable Item"_$GET(PSSPADZZ)_$GET(NEWOI)_$SELECT($GET(OIZDZ)'="":" "_$GET(OIZDZ),1:"")
+33 WRITE !?2,"Dispense Drugs matched to Orderable Item:"
+34 FOR PAA=0:0
SET PAA=$ORDER(^PSDRUG("ASP",OI,PAA))
if 'PAA!($GET(PSSOUT))
QUIT
Begin DoDot:2
+35 IF ($Y+4)>IOSL
DO ADDH
if $GET(PSSOUT)
QUIT
+36 KILL PSINDATE
SET PSINDAT=$PIECE($GET(^PSDRUG(PAA,"I")),"^")
IF PSINDAT
SET PSINDATE=" "_"("_$EXTRACT(PSINDAT,4,5)_"/"_$EXTRACT(PSINDAT,6,7)_"/"_$EXTRACT(PSINDAT,2,3)_")"
+37 IF PSINDAT
IF PSINDAT<$GET(PSSYRX)
QUIT
+38 WRITE !?4,$PIECE($GET(^PSDRUG(PAA,0)),"^")_$GET(PSINDATE)
IF PAA=$PIECE(ZERO,"^",2)
WRITE ?55,"(Additive link)"
End DoDot:2
End DoDot:1
+39 IF $GET(PSSOUT)
GOTO ADDX
+40 DO ADDHS
if $GET(PSSOUT)
GOTO ADDX
+41 SET PSSADSUM=1
+42 SET AA=""
FOR
SET AA=$ORDER(^TMP($JOB,"PSSAD",AA))
if AA=""!($GET(PSSOUT))
QUIT
Begin DoDot:1
+43 SET AAZ=$ORDER(^TMP($JOB,"PSSAD",AA,0))
SET AAZZ=+$GET(^TMP($JOB,"PSSAD",AA,+$GET(AAZ)))
+44 IF ($Y+4)>IOSL
DO ADDH
if $GET(PSSOUT)
QUIT
+45 WRITE !!,"OI => ",AA_$SELECT($PIECE($GET(^PS(50.7,AAZZ,0)),"^",4)="":"",1:" ("_$EXTRACT($PIECE($GET(^(0)),"^",4),4,5)_"/"_$EXTRACT($PIECE($GET(^(0)),"^",4),6,7)_"/"_$EXTRACT($PIECE($GET(^(0)),"^",4),2,3)_")")
+46 FOR PZZ=0:0
SET PZZ=$ORDER(^TMP($JOB,"PSSAD",AA,PZZ))
if 'PZZ!($GET(PSSOUT))
QUIT
Begin DoDot:2
+47 IF ($Y+4)>IOSL
DO ADDH
if $GET(PSSOUT)
QUIT
+48 WRITE !,"("_$GET(PZZ)_") ",?13,$PIECE($GET(^PS(52.6,PZZ,0)),"^")_$SELECT($PIECE($GET(^("I")),"^")="":"",1:" ("_$EXTRACT($PIECE($GET(^("I")),"^"),4,5)_"/"_$EXTRACT($PIECE($GET(^("I")),"^"),6,7)_"/"_$EXTRACT($PIECE(...
... $GET(^("I")),"^"),2,3)_")"),?69,"(Additive)"
End DoDot:2
+49 if $GET(PSSOUT)
QUIT
+50 WRITE !?2,"Dispense Drugs matched to OI:"
+51 FOR PDD=0:0
SET PDD=$ORDER(^PSDRUG("ASP",AAZZ,PDD))
if 'PDD!($GET(PSSOUT))
QUIT
Begin DoDot:2
+52 IF ($Y+4)>IOSL
DO ADDH
if $GET(PSSOUT)
QUIT
+53 IF $PIECE($GET(^PSDRUG(PDD,"I")),"^")
IF $PIECE($GET(^("I")),"^")<$GET(PSSYRX)
QUIT
+54 WRITE !,?11,$PIECE($GET(^PSDRUG(PDD,0)),"^")_$SELECT($PIECE($GET(^("I")),"^")="":"",1:" ("_$EXTRACT($PIECE($GET(^("I")),"^"),4,5)_"/"_$EXTRACT($PIECE($GET(^("I")),"^"),6,7)_"/"_$EXTRACT($PIECE($GET(^("I")),"^"),2,3)_")")
End DoDot:2
End DoDot:1
ADDX ;
+1 KILL ^TMP($JOB,"PSSAD")
+2 IF $GET(PSSTYPE)="B"
IF '$GET(PSSOUT)
GOTO SOL
+3 IF '$GET(PSSOUT)
DO PDIR
+4 GOTO END
SOL ;
+1 KILL ^TMP($JOB,"PSSOL"),PSSCOTX
+2 SET PSSWH="S"
+3 NEW SOL,SLDD,SZZ,SOLAA,SAA,SOLIEN,SNAME,SLNEWOI,SOINAME,SOIDOSE,SOILT,SOILTX,STOTAL,SLOI,SDA,SDAT,SDOI,SDOID,SOLLT,PSSSOLZ,SOIZD,SOIZDZ,SZL,SZLA,SLID,SLIDD
+4 DO SOLH
SET PSSCOTX=1
+5 IF $GET(PSSOUT)
GOTO SEND
+6 SET SOL=""
FOR
SET SOL=$ORDER(^PS(52.7,"B",SOL))
if SOL=""!($GET(PSSOUT))
QUIT
FOR SOLIEN=0:0
SET SOLIEN=$ORDER(^PS(52.7,"B",SOL,SOLIEN))
if 'SOLIEN!($GET(PSSOUT))
QUIT
Begin DoDot:1
+7 if '$PIECE($GET(^PS(52.7,SOLIEN,0)),"^",11)
QUIT
+8 SET ZERO=$GET(^PS(52.7,SOLIEN,0))
+9 SET SNAME=$PIECE(ZERO,"^")_" ("_$PIECE(ZERO,"^",3)_")"
SET LEN=$LENGTH(SNAME)
+10 KILL SDAT
SET SDA=$PIECE($GET(^PS(52.7,SOLIEN,"I")),"^")
IF SDA
SET SDAT="("_$EXTRACT(SDA,4,5)_"/"_$EXTRACT(SDA,6,7)_"/"_$EXTRACT(SDA,2,3)_")"
+11 SET LEN=LEN+$SELECT($GET(SDAT)'="":11,1:0)
+12 KILL PAD
SET $PIECE(PAD,"=",(53-LEN))=""
SET PAD=$GET(PAD)_"> "
+13 SET SOINAME=$PIECE($GET(^PS(50.7,+$PIECE(ZERO,"^",11),0)),"^")
SET SOIDOSE=$PIECE($GET(^PS(50.606,+$PIECE($GET(^(0)),"^",2),0)),"^")
SET SOILT=$LENGTH($GET(SOINAME))+$LENGTH($GET(SOIDOSE))+2
+14 KILL SDOID
SET SDOI=$PIECE($GET(^PS(50.7,+$PIECE(ZERO,"^",11),0)),"^",4)
IF SDOI
SET SDOID="("_$EXTRACT(SDOI,4,5)_"/"_$EXTRACT(SDOI,6,7)_"/"_$EXTRACT(SDOI,2,3)_")"
+15 SET SOLLT=$LENGTH(SOLIEN)+3
+16 SET PSSTOTAL=+$GET(SOLLT)+67+$GET(SOILT)+$SELECT($GET(PDOID)'="":11,1:0)+$GET(PSSIVIDL)
+17 SET PSSSOLZ=+$GET(SOLLT)+53
+18 IF ($Y+5)>IOSL
DO SOLH
if $GET(PSSOUT)
QUIT
+19 WRITE !!?3,"Current Solution/Orderable Item match:",!
+20 IF $GET(PSSTOTAL)<132
WRITE "("_$GET(SOLIEN)_") "_$GET(SNAME)_$SELECT($GET(SDAT)'="":" "_$GET(SDAT),1:"")_$GET(PAD)_$GET(SOINAME)_" "_$GET(SOIDOSE)_$SELECT($GET(SDOID)'="":" "_$GET(SDOID),1:"")_" "_$GET(PSSIVID)
+21 IF $GET(PSSTOTAL)>131
WRITE "("_$GET(SOLIEN)_") "_$GET(SNAME)_$SELECT($GET(SDAT)'="":" "_$GET(SDAT),1:"")_$GET(PAD)
if ($Y+4)>IOSL
DO SOLH
if $GET(PSSOUT)
QUIT
WRITE !,"=====> ",$GET(SOINAME)_" "_$GET(SOIDOSE)_$SELECT($GET(SDOID)'="":" "_$GET(SDOID),1:"")_" "_$GET(PSSIVID)
+22 SET SLOI=$PIECE($GET(^PSDRUG(+$PIECE(ZERO,"^",2),2)),"^")
IF 'SLOI
WRITE !?5,"cannot rematch, no Item for the Dispense Drug"
QUIT
+23 SET PSSSTMP=$PIECE($GET(^PS(50.7,+$GET(SLOI),0)),"^")_" "_$PIECE($GET(^PS(50.606,+$PIECE($GET(^(0)),"^",2),0)),"^")
+24 SET ^TMP($JOB,"PSSOL",PSSSTMP,SOLIEN)=SLOI
+25 SET SLNEWOI=$PIECE($GET(^PS(50.7,+$GET(SLOI),0)),"^")_" "_$PIECE($GET(^PS(50.606,+$PIECE($GET(^(0)),"^",2),0)),"^")
+26 KILL SOIZDZ
SET SOIZD=$PIECE($GET(^PS(50.7,+$GET(SLOI),0)),"^",4)
IF SOIZD
SET SOIZDZ="("_$EXTRACT(SOIZD,4,5)_"/"_$EXTRACT(SOIZD,6,7)_"/"_$EXTRACT(SOIZD,2,3)_")"
+27 KILL SZL
SET SZLA=$GET(PSSSOLZ)-18
SET $PIECE(SZL,"=",SZLA)=""
SET SZL=SZL_"> "
+28 WRITE !,"New Orderable Item"_$GET(SZL)_$GET(SLNEWOI)_$SELECT($GET(SOIZDZ)'="":" "_$GET(SOIZDZ),1:"")
+29 WRITE !?2,"Dispense Drugs matched to Orderable Item:"
+30 FOR SAA=0:0
SET SAA=$ORDER(^PSDRUG("ASP",SLOI,SAA))
if 'SAA!($GET(PSSOUT))
QUIT
Begin DoDot:2
+31 IF ($Y+4)>IOSL
DO SOLH
if $GET(PSSOUT)
QUIT
+32 KILL SLID
SET SLIDD=$PIECE($GET(^PSDRUG(SAA,"I")),"^")
IF SLIDD
SET SLID=" "_"("_$EXTRACT(SLIDD,4,5)_"/"_$EXTRACT(SLIDD,6,7)_"/"_$EXTRACT(SLIDD,2,3)_")"
+33 IF SLIDD
IF SLIDD<$GET(PSSYRX)
QUIT
+34 WRITE !?4,$PIECE($GET(^PSDRUG(SAA,0)),"^")_$GET(SLID)
IF SAA=$PIECE(ZERO,"^",2)
WRITE ?59,"(Solution link)"
End DoDot:2
End DoDot:1
+35 IF $GET(PSSOUT)
GOTO SEND
+36 DO SOLHS
if $GET(PSSOUT)
GOTO SEND
+37 SET PSSSOSUM=1
+38 SET SOLAA=""
FOR
SET SOLAA=$ORDER(^TMP($JOB,"PSSOL",SOLAA))
if SOLAA=""!($GET(PSSOUT))
QUIT
Begin DoDot:1
+39 SET SSZ=$ORDER(^TMP($JOB,"PSSOL",SOLAA,0))
SET SSZZ=+$GET(^TMP($JOB,"PSSOL",SOLAA,+$GET(SSZ)))
+40 IF ($Y+4)>IOSL
DO SOLH
if $GET(PSSOUT)
QUIT
+41 WRITE !!,"OI => ",SOLAA_$SELECT($PIECE($GET(^PS(50.7,SSZZ,0)),"^",4)="":"",1:" ("_$EXTRACT($PIECE($GET(^(0)),"^",4),4,5)_"/"_$EXTRACT($PIECE($GET(^(0)),"^",4),6,7)_"/"_$EXTRACT($PIECE($GET(^(0)),"^",4),2,3)_")")
+42 FOR SZZ=0:0
SET SZZ=$ORDER(^TMP($JOB,"PSSOL",SOLAA,SZZ))
if 'SZZ!($GET(PSSOUT))
QUIT
Begin DoDot:2
+43 IF ($Y+4)>IOSL
DO SOLH
if $GET(PSSOUT)
QUIT
+44 WRITE !,"("_$GET(SZZ)_") ",?13,$PIECE($GET(^PS(52.7,SZZ,0)),"^")_" ("_$PIECE($GET(^(0)),"^",3)_")"_$SELECT($PIECE($GET(^("I")),"^")="":"",1:" ("_$EXTRACT($PIECE($GET(^("I")),"^"),4,5)_"/"_...
... $EXTRACT($PIECE($GET(^("I")),"^"),6,7)_"/"_$EXTRACT($PIECE($GET(^("I")),"^"),2,3)_")")
WRITE ?67,"(Solution)"
End DoDot:2
+45 if $GET(PSSOUT)
QUIT
+46 WRITE !?2,"Dispense Drugs matched to OI:"
+47 FOR SLDD=0:0
SET SLDD=$ORDER(^PSDRUG("ASP",SSZZ,SLDD))
if 'SLDD!($GET(PSSOUT))
QUIT
Begin DoDot:2
+48 IF ($Y+4)>IOSL
DO SOLH
if $GET(PSSOUT)
QUIT
+49 IF $PIECE($GET(^PSDRUG(SLDD,"I")),"^")
IF $PIECE($GET(^("I")),"^")<$GET(PSSYRX)
QUIT
+50 WRITE !?11,$PIECE($GET(^PSDRUG(SLDD,0)),"^")_$SELECT($PIECE($GET(^("I")),"^")="":"",1:" ("_$EXTRACT($PIECE($GET(^("I")),"^"),4,5)_"/"_$EXTRACT($PIECE($GET(^("I")),"^"),6,7)_"/"_$EXTRACT($PIECE($GET(^("I")),"^"),2,3)_")")
End DoDot:2
End DoDot:1
+51 IF '$GET(PSSOUT)
DO PDIR
SEND ;
+1 KILL ^TMP($JOB,"PSSOL")
END IF $GET(PSSDV)="C"
WRITE !
+1 IF '$TEST
WRITE @IOF
+2 KILL PSSTOTAL,PSSIVID,PSSIVIDL,PSSTYPE,PSSDV,PSSWH,PSSCOT,PSSOUT,PSSCOTX,PSSADSUM,PSSSOSUM,PSSYRX
+3 DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
ADDH ;
+1 IF $GET(PSSCOT)=1
WRITE @IOF
WRITE !?5,"ADDITIVE REPORT (Additive Internal number in parenthesis)",?67,"PAGE: "_$GET(PSSCOT)
SET PSSCOT=PSSCOT+1
QUIT
+2 IF $GET(PSSDV)="C"
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
+3 WRITE @IOF
WRITE !?8,"ADDITIVE "_$SELECT('$GET(PSSADSUM):"REPORT",1:"SUMMARY")_" (continued)"
WRITE ?67,"PAGE: "_$GET(PSSCOT)
SET PSSCOT=PSSCOT+1
+4 QUIT
ADDHS ;
+1 IF $GET(PSSDV)="C"
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 !!?5,"ADDITIVE SUMMARY"
WRITE ?67,"PAGE: "_$GET(PSSCOT)
SET PSSCOT=PSSCOT+1
+3 QUIT
SOLH ;
+1 IF '$GET(PSSCOTX)
Begin DoDot:1
+2 IF $GET(PSSDV)="C"
IF $GET(PSSCOT)'=1
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to continue, '^' to exit"
DO ^DIR
KILL DIR
IF 'Y
SET PSSOUT=1
End DoDot:1
if $GET(PSSOUT)
QUIT
WRITE @IOF
WRITE !?5,"SOLUTION REPORT (Solution Internal number in parenthesis)",?67,"PAGE: "_$GET(PSSCOT)
SET PSSCOT=PSSCOT+1
QUIT
+3 IF $GET(PSSDV)="C"
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
+4 WRITE @IOF
WRITE !?8,"SOLUTION "_$SELECT('$GET(PSSSOSUM):"REPORT",1:"SUMMARY")_" (continued)"
WRITE ?67,"PAGE: "_$GET(PSSCOT)
SET PSSCOT=PSSCOT+1
+5 QUIT
SOLHS ;
+1 IF $GET(PSSDV)="C"
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 !!?5,"SOLUTION SUMMARY"
WRITE ?67,"PAGE: "_$GET(PSSCOT)
SET PSSCOT=PSSCOT+1
+3 QUIT
PDIR ;
+1 if $GET(PSSDV)'="C"
QUIT
+2 WRITE !
SET DIR(0)="E"
SET DIR("A")="Pres Return to continue, '^' to exit"
DO ^DIR
KILL DIR
IF 'Y
SET PSSOUT=1
+3 QUIT
