PSAREORD ;BIR/JMB-Nightly Background Job - CONT'D ;7/23/97
;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,21**; 10/24/97
;References to ^PSDRUG( are covered by IA #2095
;References to ^DIC(51.5 are covered by IA #1931
;This routine checks each pharmacy location for current balances less
;than or equal to the reorder level. A list is sent to the holders of
;the PSA ORDERS key. If the location is a master vault, the message
;will include those CS drugs only if the user has the PSJ RPHARM key.
;
PHARM ;Looks for drugs that are >= reorder level in pharmacy locations.
K ^TMP("PSAMSGO",$J),^TMP("PSAREORD",$J) S (PSACNT,PSALOC)=0
F S PSALOC=$O(^PSD(58.8,"ADISP","P",PSALOC)) Q:'PSALOC D
.Q:'$P($G(^PSD(58.8,PSALOC,0)),"^",14)!('$D(^PSD(58.8,PSALOC,0)))
.I +$G(^PSD(58.8,PSALOC,"I")),+^PSD(58.8,PSALOC,"I")'>DT Q
.S PSAFIRST=1,PSADRG=0
.F S PSADRG=+$O(^PSD(58.8,PSALOC,1,PSADRG)) Q:'PSADRG D
..S PSANODE=$G(^PSD(58.8,PSALOC,1,PSADRG,0)) Q:PSANODE=""
..Q:+$P(PSANODE,"^",4)>+$P(PSANODE,"^",5)
..Q:'+$P(PSANODE,"^",4)&('+$P(PSANODE,"^",5))
..S PSANDC=$P($G(^PSDRUG(PSADRG,2)),"^",4) K PSALVSN D:PSANDC'="" NDC
..S ^TMP("PSAORD",$J,PSALOC,$S($P($G(^PSDRUG(PSADRG,0)),"^")'="":$P(^PSDRUG(PSADRG,0),"^"),1:"UNKNOWN ("_PSADRG_")"))=+$P(PSANODE,"^",3)_"^"_+$P(PSANODE,"^",4)_"^"_$G(PSALVSN)
K PSALVSN
;
VAULT ;Looks for drugs that are >= reorder level in master vaults.
S PSALOC=0 F S PSALOC=$O(^PSD(58.8,"ADISP","M",PSALOC)) Q:'PSALOC D
.Q:'$P($G(^PSD(58.8,PSALOC,0)),"^",14)!('$D(^PSD(58.8,PSALOC,0)))
.I +$G(^PSD(58.8,PSALOC,"I")),+^PSD(58.8,PSALOC,"I")'>DT Q
.S PSAFIRST=1,PSADRG=0
.F S PSADRG=$O(^PSD(58.8,PSALOC,1,PSADRG)) Q:'PSADRG D
..S PSANODE=$G(^PSD(58.8,PSALOC,1,PSADRG,0))
..Q:PSANODE=""!(+$P(PSANODE,"^",4)>+$P(PSANODE,"^",5))
..Q:'+$P(PSANODE,"^",4)&('+$P(PSANODE,"^",5))
..S PSANDC=$P($G(^PSDRUG(PSADRG,2)),"^",4) K PSALVSN D:PSANDC'="" NDC
..S ^TMP("PSAORDCS",$J,PSALOC,$S($P($G(^PSDRUG(PSADRG,0)),"^")'="":$P(^PSDRUG(PSADRG,0),"^"),1:"UNKNOWN ("_PSADRG_")"))=+$P(PSANODE,"^",3)_"^"_+$P(PSANODE,"^",4)_"^"_$G(PSALVSN)
K PSALVSN I '$O(^TMP("PSAORD",$J,0)),'$O(^TMP("PSAORDCS",$J,0)) G EXIT
;
NONCS ;Loops through the non-controlled subs to create mail message text.
G:'$O(^TMP("PSAORD",$J,0)) CS K PSA S (PSACNT,PSALOC)=0
F S PSALOC=$O(^TMP("PSAORD",$J,PSALOC)) Q:'PSALOC D
.S PSAFIRST=1,PSADRG=""
.F S PSADRG=$O(^TMP("PSAORD",$J,PSALOC,PSADRG)) Q:PSADRG="" D
..S PSASTOCK=$P(^TMP("PSAORD",$J,PSALOC,PSADRG),"^"),PSABAL=$P(^(PSADRG),"^",2),PSAVSN=$P(^(PSADRG),"^",3) D SETMSG
G:'$D(^XUSEC("PSJ RPHARM",DUZ))!('$O(^TMP("PSAORDCS",$J,0))) SEND
;
CS ;Loops through the controlled subs to create mail message text.
S PSALOC=0 F S PSALOC=$O(^TMP("PSAORDCS",$J,PSALOC)) Q:'PSALOC D
.S PSAFIRST=1,PSADRG=""
.F S PSADRG=$O(^TMP("PSAORDCS",$J,PSALOC,PSADRG)) Q:PSADRG="" D
..S PSASTOCK=$P(^TMP("PSAORDCS",$J,PSALOC,PSADRG),"^"),PSABAL=$P(^(PSADRG),"^",2),PSAVSN=$P(^(PSADRG),"^",3) D SETMSG
;
SEND ;Send the mail message to the holders of the PSA ORDERS key.
S XMTEXT="^TMP(""PSAMSGO"",$J,",XMDUZ="Drug Accountability System",XMSUB="Drug Balances Below Reorder Level"
;PSA*3*21 ( change recipients to PSA REORDER LEVEL mail group
S XMY("G.PSA REORDER LEVEL")=""
G:'$D(XMY) QUIT D ^XMD
QUIT K XMY,^TMP("PSAMSGO",$J)
Q
;
NDC ;Gets VSN dispense units,dispense units/order unit, order unit for
;^TMP global
K PSASYN,PSAVSN,PSAOU,PSADUOU,PSADU,PSALVSN
S PSANDC=$E("000000",1,(6-$L($P(PSANDC,"-"))))_$P(PSANDC,"-")_$E("0000",1,(4-$L($P(PSANDC,"-",2))))_$P(PSANDC,"-",2)_$E("00",1,(2-$L($P(PSANDC,"-",3))))_$P(PSANDC,"-",3)
S PSASYN=+$O(^PSDRUG("C",PSANDC,PSADRG,0)) Q:'PSASYN!('$D(^PSDRUG(PSADRG,1,PSASYN,0)))
S PSAVSN=$P(^PSDRUG(PSADRG,1,PSASYN,0),"^",4),PSAOU=$S(+$P(^(0),"^",5):$P($G(^DIC(51.5,+$P(^(0),"^",5),0)),"^"),1:"")
S PSADUOU=$S(+$P(^PSDRUG(PSADRG,1,PSASYN,0),"^",7):+$P(^(0),"^",7),1:""),PSADU=$P($G(^PSDRUG(PSADRG,660)),"^",8)
Q:PSAVSN=""
S PSALVSN="VSN: "_PSAVSN I PSAOU'="",+PSADUOU,PSADU'="" S PSALVSN=PSALVSN_" "_PSADUOU_" "_PSADU_"/"_PSAOU
K PSASYN,PSAVSN,PSAOU,PSADUOU,PSADU
Q
SETMSG ;Creates the body of the mail message.
I PSAFIRST D
.I PSACNT'=0 S PSACNT=PSACNT+1,^TMP("PSAMSGO",$J,PSACNT)="=============================================================================",PSACNT=PSACNT+1,^TMP("PSAMSGO",$J,PSACNT)=" "
.K PSALOCA D SITES^PSAUTL1 S PSALOCA($P(^PSD(58.8,PSALOC,0),"^")_PSACOMB,PSALOC)=PSAISIT_"^"_PSAOSIT,PSALOCN=$O(PSALOCA("")),PSAFIRST=0
.S PSACNT=PSACNT+1,PSACNT(PSACNT)=$S($P(^PSD(58.8,PSALOC,0),"^",2)="P":"PHARMACY LOCATION",1:"MASTER VAULT")
.I $L(PSALOCN)>76 S PSACNT=PSACNT+1,^TMP("PSAMSGO",$J,PSACNT)=$P(PSALOCN,"(IP)",1)_"(IP)" S PSACNT=PSACNT+1,^TMP("PSAMSGO",$J,PSACNT)=" "_$P(PSALOCN,"(IP)",2)
.I $L(PSALOCN)<77 S PSACNT=PSACNT+1,^TMP("PSAMSGO",$J,PSACNT)=PSALOCN
.S PSACNT=PSACNT+1,^TMP("PSAMSGO",$J,PSACNT)=" Stock Current Amount to"
.S PSACNT=PSACNT+1,^TMP("PSAMSGO",$J,PSACNT)="Drug Name: Level Balance Order"
.S PSACNT=PSACNT+1,^TMP("PSAMSGO",$J,PSACNT)="-----------------------------------------------------------------------------"
S PSALEN=$L(PSADRG),PSASPACE=$E(" ",1,(42-PSALEN))
S PSACNT=PSACNT+1,^TMP("PSAMSGO",$J,PSACNT)=PSADRG_PSASPACE_$J(PSASTOCK,6,0)_" "_$J(PSABAL,6,0)_" "_$S((PSASTOCK-PSABAL)>.001:$J((PSASTOCK-PSABAL),6,0),1:" N/A")
S PSACNT=PSACNT+1 S:$G(PSAVSN)'="" ^TMP("PSAMSGO",$J,PSACNT)=" "_PSAVSN
Q
;
EXIT ;Kills the variables & TMP globals.
K ^TMP("PSAMSGO",$J),^TMP("PSAORD",$J),^TMP("PSAORDCS",$J)
K PSA,PSABAL,PSACNT,PSACOMB,PSADRG,PSAFIRST,PSAISIT,PSALEN,PSALOC,PSALOCA,PSALOCN,PSANODE,PSAOSIT,PSAISITN,PSAOSITN,PSASPACE,PSASTOCK,XMDUZ,XMSUB,XMTEXT,XMY
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSAREORD 5874 printed Sep 23, 2025@19:26:34 Page 2
PSAREORD ;BIR/JMB-Nightly Background Job - CONT'D ;7/23/97
+1 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,21**; 10/24/97
+2 ;References to ^PSDRUG( are covered by IA #2095
+3 ;References to ^DIC(51.5 are covered by IA #1931
+4 ;This routine checks each pharmacy location for current balances less
+5 ;than or equal to the reorder level. A list is sent to the holders of
+6 ;the PSA ORDERS key. If the location is a master vault, the message
+7 ;will include those CS drugs only if the user has the PSJ RPHARM key.
+8 ;
PHARM ;Looks for drugs that are >= reorder level in pharmacy locations.
+1 KILL ^TMP("PSAMSGO",$JOB),^TMP("PSAREORD",$JOB)
SET (PSACNT,PSALOC)=0
+2 FOR
SET PSALOC=$ORDER(^PSD(58.8,"ADISP","P",PSALOC))
if 'PSALOC
QUIT
Begin DoDot:1
+3 if '$PIECE($GET(^PSD(58.8,PSALOC,0)),"^",14)!('$DATA(^PSD(58.8,PSALOC,0)))
QUIT
+4 IF +$GET(^PSD(58.8,PSALOC,"I"))
IF +^PSD(58.8,PSALOC,"I")'>DT
QUIT
+5 SET PSAFIRST=1
SET PSADRG=0
+6 FOR
SET PSADRG=+$ORDER(^PSD(58.8,PSALOC,1,PSADRG))
if 'PSADRG
QUIT
Begin DoDot:2
+7 SET PSANODE=$GET(^PSD(58.8,PSALOC,1,PSADRG,0))
if PSANODE=""
QUIT
+8 if +$PIECE(PSANODE,"^",4)>+$PIECE(PSANODE,"^",5)
QUIT
+9 if '+$PIECE(PSANODE,"^",4)&('+$PIECE(PSANODE,"^",5))
QUIT
+10 SET PSANDC=$PIECE($GET(^PSDRUG(PSADRG,2)),"^",4)
KILL PSALVSN
if PSANDC'=""
DO NDC
+11 SET ^TMP("PSAORD",$JOB,PSALOC,$SELECT($PIECE($GET(^PSDRUG(PSADRG,0)),"^")'="":$PIECE(^PSDRUG(PSADRG,0),"^"),1:"UNKNOWN ("_PSADRG_")"))=+$PIECE(PSANODE,"^",3)_"^"_+$PIECE(PSANODE,"^",4)_"^"_$GET(PSALVSN)
End DoDot:2
End DoDot:1
+12 KILL PSALVSN
+13 ;
VAULT ;Looks for drugs that are >= reorder level in master vaults.
+1 SET PSALOC=0
FOR
SET PSALOC=$ORDER(^PSD(58.8,"ADISP","M",PSALOC))
if 'PSALOC
QUIT
Begin DoDot:1
+2 if '$PIECE($GET(^PSD(58.8,PSALOC,0)),"^",14)!('$DATA(^PSD(58.8,PSALOC,0)))
QUIT
+3 IF +$GET(^PSD(58.8,PSALOC,"I"))
IF +^PSD(58.8,PSALOC,"I")'>DT
QUIT
+4 SET PSAFIRST=1
SET PSADRG=0
+5 FOR
SET PSADRG=$ORDER(^PSD(58.8,PSALOC,1,PSADRG))
if 'PSADRG
QUIT
Begin DoDot:2
+6 SET PSANODE=$GET(^PSD(58.8,PSALOC,1,PSADRG,0))
+7 if PSANODE=""!(+$PIECE(PSANODE,"^",4)>+$PIECE(PSANODE,"^",5))
QUIT
+8 if '+$PIECE(PSANODE,"^",4)&('+$PIECE(PSANODE,"^",5))
QUIT
+9 SET PSANDC=$PIECE($GET(^PSDRUG(PSADRG,2)),"^",4)
KILL PSALVSN
if PSANDC'=""
DO NDC
+10 SET ^TMP("PSAORDCS",$JOB,PSALOC,$SELECT($PIECE($GET(^PSDRUG(PSADRG,0)),"^")'="":$PIECE(^PSDRUG(PSADRG,0),"^"),1:"UNKNOWN ("_PSADRG_")"))=+$PIECE(PSANODE,"^",3)_"^"_+$PIECE(PSANODE,"^",4)_"^"_$GET(PSALVSN)
End DoDot:2
End DoDot:1
+11 KILL PSALVSN
IF '$ORDER(^TMP("PSAORD",$JOB,0))
IF '$ORDER(^TMP("PSAORDCS",$JOB,0))
GOTO EXIT
+12 ;
NONCS ;Loops through the non-controlled subs to create mail message text.
+1 if '$ORDER(^TMP("PSAORD",$JOB,0))
GOTO CS
KILL PSA
SET (PSACNT,PSALOC)=0
+2 FOR
SET PSALOC=$ORDER(^TMP("PSAORD",$JOB,PSALOC))
if 'PSALOC
QUIT
Begin DoDot:1
+3 SET PSAFIRST=1
SET PSADRG=""
+4 FOR
SET PSADRG=$ORDER(^TMP("PSAORD",$JOB,PSALOC,PSADRG))
if PSADRG=""
QUIT
Begin DoDot:2
+5 SET PSASTOCK=$PIECE(^TMP("PSAORD",$JOB,PSALOC,PSADRG),"^")
SET PSABAL=$PIECE(^(PSADRG),"^",2)
SET PSAVSN=$PIECE(^(PSADRG),"^",3)
DO SETMSG
End DoDot:2
End DoDot:1
+6 if '$DATA(^XUSEC("PSJ RPHARM",DUZ))!('$ORDER(^TMP("PSAORDCS",$JOB,0)))
GOTO SEND
+7 ;
CS ;Loops through the controlled subs to create mail message text.
+1 SET PSALOC=0
FOR
SET PSALOC=$ORDER(^TMP("PSAORDCS",$JOB,PSALOC))
if 'PSALOC
QUIT
Begin DoDot:1
+2 SET PSAFIRST=1
SET PSADRG=""
+3 FOR
SET PSADRG=$ORDER(^TMP("PSAORDCS",$JOB,PSALOC,PSADRG))
if PSADRG=""
QUIT
Begin DoDot:2
+4 SET PSASTOCK=$PIECE(^TMP("PSAORDCS",$JOB,PSALOC,PSADRG),"^")
SET PSABAL=$PIECE(^(PSADRG),"^",2)
SET PSAVSN=$PIECE(^(PSADRG),"^",3)
DO SETMSG
End DoDot:2
End DoDot:1
+5 ;
SEND ;Send the mail message to the holders of the PSA ORDERS key.
+1 SET XMTEXT="^TMP(""PSAMSGO"",$J,"
SET XMDUZ="Drug Accountability System"
SET XMSUB="Drug Balances Below Reorder Level"
+2 ;PSA*3*21 ( change recipients to PSA REORDER LEVEL mail group
+3 SET XMY("G.PSA REORDER LEVEL")=""
+4 if '$DATA(XMY)
GOTO QUIT
DO ^XMD
QUIT KILL XMY,^TMP("PSAMSGO",$JOB)
+1 QUIT
+2 ;
NDC ;Gets VSN dispense units,dispense units/order unit, order unit for
+1 ;^TMP global
+2 KILL PSASYN,PSAVSN,PSAOU,PSADUOU,PSADU,PSALVSN
+3 SET PSANDC=$EXTRACT("000000",1,(6-$LENGTH($PIECE(PSANDC,"-"))))_$PIECE(PSANDC,"-")_$EXTRACT("0000",1,(4-$LENGTH($PIECE(PSANDC,"-",2))))_$PIECE(PSANDC,"-",2)_$EXTRACT("00",1,(2-$LENGTH($PIECE(PSANDC,"-",3))))_$PIECE(PSANDC,"-",3)
+4 SET PSASYN=+$ORDER(^PSDRUG("C",PSANDC,PSADRG,0))
if 'PSASYN!('$DATA(^PSDRUG(PSADRG,1,PSASYN,0)))
QUIT
+5 SET PSAVSN=$PIECE(^PSDRUG(PSADRG,1,PSASYN,0),"^",4)
SET PSAOU=$SELECT(+$PIECE(^(0),"^",5):$PIECE($GET(^DIC(51.5,+$PIECE(^(0),"^",5),0)),"^"),1:"")
+6 SET PSADUOU=$SELECT(+$PIECE(^PSDRUG(PSADRG,1,PSASYN,0),"^",7):+$PIECE(^(0),"^",7),1:"")
SET PSADU=$PIECE($GET(^PSDRUG(PSADRG,660)),"^",8)
+7 if PSAVSN=""
QUIT
+8 SET PSALVSN="VSN: "_PSAVSN
IF PSAOU'=""
IF +PSADUOU
IF PSADU'=""
SET PSALVSN=PSALVSN_" "_PSADUOU_" "_PSADU_"/"_PSAOU
+9 KILL PSASYN,PSAVSN,PSAOU,PSADUOU,PSADU
+10 QUIT
SETMSG ;Creates the body of the mail message.
+1 IF PSAFIRST
Begin DoDot:1
+2 IF PSACNT'=0
SET PSACNT=PSACNT+1
SET ^TMP("PSAMSGO",$JOB,PSACNT)="============================================================================="
SET PSACNT=PSACNT+1
SET ^TMP("PSAMSGO",$JOB,PSACNT)=" "
+3 KILL PSALOCA
DO SITES^PSAUTL1
SET PSALOCA($PIECE(^PSD(58.8,PSALOC,0),"^")_PSACOMB,PSALOC)=PSAISIT_"^"_PSAOSIT
SET PSALOCN=$ORDER(PSALOCA(""))
SET PSAFIRST=0
+4 SET PSACNT=PSACNT+1
SET PSACNT(PSACNT)=$SELECT($PIECE(^PSD(58.8,PSALOC,0),"^",2)="P":"PHARMACY LOCATION",1:"MASTER VAULT")
+5 IF $LENGTH(PSALOCN)>76
SET PSACNT=PSACNT+1
SET ^TMP("PSAMSGO",$JOB,PSACNT)=$PIECE(PSALOCN,"(IP)",1)_"(IP)"
SET PSACNT=PSACNT+1
SET ^TMP("PSAMSGO",$JOB,PSACNT)=" "_$PIECE(PSALOCN,"(IP)",2)
+6 IF $LENGTH(PSALOCN)<77
SET PSACNT=PSACNT+1
SET ^TMP("PSAMSGO",$JOB,PSACNT)=PSALOCN
+7 SET PSACNT=PSACNT+1
SET ^TMP("PSAMSGO",$JOB,PSACNT)=" Stock Current Amount to"
+8 SET PSACNT=PSACNT+1
SET ^TMP("PSAMSGO",$JOB,PSACNT)="Drug Name: Level Balance Order"
+9 SET PSACNT=PSACNT+1
SET ^TMP("PSAMSGO",$JOB,PSACNT)="-----------------------------------------------------------------------------"
End DoDot:1
+10 SET PSALEN=$LENGTH(PSADRG)
SET PSASPACE=$EXTRACT(" ",1,(42-PSALEN))
+11 SET PSACNT=PSACNT+1
SET ^TMP("PSAMSGO",$JOB,PSACNT)=PSADRG_PSASPACE_$JUSTIFY(PSASTOCK,6,0)_" "_$JUSTIFY(PSABAL,6,0)_" "_$SELECT((PSASTOCK-PSABAL)>.001:$JUSTIFY((PSASTOCK-PSABAL),6,0),1:" N/A")
+12 SET PSACNT=PSACNT+1
if $GET(PSAVSN)'=""
SET ^TMP("PSAMSGO",$JOB,PSACNT)=" "_PSAVSN
+13 QUIT
+14 ;
EXIT ;Kills the variables & TMP globals.
+1 KILL ^TMP("PSAMSGO",$JOB),^TMP("PSAORD",$JOB),^TMP("PSAORDCS",$JOB)
+2 KILL PSA,PSABAL,PSACNT,PSACOMB,PSADRG,PSAFIRST,PSAISIT,PSALEN,PSALOC,PSALOCA,PSALOCN,PSANODE,PSAOSIT,PSAISITN,PSAOSITN,PSASPACE,PSASTOCK,XMDUZ,XMSUB,XMTEXT,XMY
+3 QUIT
