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

PSAREORD.m

Go to the documentation of this file.
  1. PSAREORD ;BIR/JMB-Nightly Background Job - CONT'D ;7/23/97
  1. ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,21**; 10/24/97
  1. ;References to ^PSDRUG( are covered by IA #2095
  1. ;References to ^DIC(51.5 are covered by IA #1931
  1. ;This routine checks each pharmacy location for current balances less
  1. ;than or equal to the reorder level. A list is sent to the holders of
  1. ;the PSA ORDERS key. If the location is a master vault, the message
  1. ;will include those CS drugs only if the user has the PSJ RPHARM key.
  1. ;
  1. PHARM ;Looks for drugs that are >= reorder level in pharmacy locations.
  1. K ^TMP("PSAMSGO",$J),^TMP("PSAREORD",$J) S (PSACNT,PSALOC)=0
  1. F S PSALOC=$O(^PSD(58.8,"ADISP","P",PSALOC)) Q:'PSALOC D
  1. .Q:'$P($G(^PSD(58.8,PSALOC,0)),"^",14)!('$D(^PSD(58.8,PSALOC,0)))
  1. .I +$G(^PSD(58.8,PSALOC,"I")),+^PSD(58.8,PSALOC,"I")'>DT Q
  1. .S PSAFIRST=1,PSADRG=0
  1. .F S PSADRG=+$O(^PSD(58.8,PSALOC,1,PSADRG)) Q:'PSADRG D
  1. ..S PSANODE=$G(^PSD(58.8,PSALOC,1,PSADRG,0)) Q:PSANODE=""
  1. ..Q:+$P(PSANODE,"^",4)>+$P(PSANODE,"^",5)
  1. ..Q:'+$P(PSANODE,"^",4)&('+$P(PSANODE,"^",5))
  1. ..S PSANDC=$P($G(^PSDRUG(PSADRG,2)),"^",4) K PSALVSN D:PSANDC'="" NDC
  1. ..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)
  1. K PSALVSN
  1. ;
  1. VAULT ;Looks for drugs that are >= reorder level in master vaults.
  1. S PSALOC=0 F S PSALOC=$O(^PSD(58.8,"ADISP","M",PSALOC)) Q:'PSALOC D
  1. .Q:'$P($G(^PSD(58.8,PSALOC,0)),"^",14)!('$D(^PSD(58.8,PSALOC,0)))
  1. .I +$G(^PSD(58.8,PSALOC,"I")),+^PSD(58.8,PSALOC,"I")'>DT Q
  1. .S PSAFIRST=1,PSADRG=0
  1. .F S PSADRG=$O(^PSD(58.8,PSALOC,1,PSADRG)) Q:'PSADRG D
  1. ..S PSANODE=$G(^PSD(58.8,PSALOC,1,PSADRG,0))
  1. ..Q:PSANODE=""!(+$P(PSANODE,"^",4)>+$P(PSANODE,"^",5))
  1. ..Q:'+$P(PSANODE,"^",4)&('+$P(PSANODE,"^",5))
  1. ..S PSANDC=$P($G(^PSDRUG(PSADRG,2)),"^",4) K PSALVSN D:PSANDC'="" NDC
  1. ..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)
  1. K PSALVSN I '$O(^TMP("PSAORD",$J,0)),'$O(^TMP("PSAORDCS",$J,0)) G EXIT
  1. ;
  1. NONCS ;Loops through the non-controlled subs to create mail message text.
  1. G:'$O(^TMP("PSAORD",$J,0)) CS K PSA S (PSACNT,PSALOC)=0
  1. F S PSALOC=$O(^TMP("PSAORD",$J,PSALOC)) Q:'PSALOC D
  1. .S PSAFIRST=1,PSADRG=""
  1. .F S PSADRG=$O(^TMP("PSAORD",$J,PSALOC,PSADRG)) Q:PSADRG="" D
  1. ..S PSASTOCK=$P(^TMP("PSAORD",$J,PSALOC,PSADRG),"^"),PSABAL=$P(^(PSADRG),"^",2),PSAVSN=$P(^(PSADRG),"^",3) D SETMSG
  1. G:'$D(^XUSEC("PSJ RPHARM",DUZ))!('$O(^TMP("PSAORDCS",$J,0))) SEND
  1. ;
  1. CS ;Loops through the controlled subs to create mail message text.
  1. S PSALOC=0 F S PSALOC=$O(^TMP("PSAORDCS",$J,PSALOC)) Q:'PSALOC D
  1. .S PSAFIRST=1,PSADRG=""
  1. .F S PSADRG=$O(^TMP("PSAORDCS",$J,PSALOC,PSADRG)) Q:PSADRG="" D
  1. ..S PSASTOCK=$P(^TMP("PSAORDCS",$J,PSALOC,PSADRG),"^"),PSABAL=$P(^(PSADRG),"^",2),PSAVSN=$P(^(PSADRG),"^",3) D SETMSG
  1. ;
  1. SEND ;Send the mail message to the holders of the PSA ORDERS key.
  1. S XMTEXT="^TMP(""PSAMSGO"",$J,",XMDUZ="Drug Accountability System",XMSUB="Drug Balances Below Reorder Level"
  1. ;PSA*3*21 ( change recipients to PSA REORDER LEVEL mail group
  1. S XMY("G.PSA REORDER LEVEL")=""
  1. G:'$D(XMY) QUIT D ^XMD
  1. QUIT K XMY,^TMP("PSAMSGO",$J)
  1. Q
  1. ;
  1. NDC ;Gets VSN dispense units,dispense units/order unit, order unit for
  1. ;^TMP global
  1. K PSASYN,PSAVSN,PSAOU,PSADUOU,PSADU,PSALVSN
  1. 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)
  1. S PSASYN=+$O(^PSDRUG("C",PSANDC,PSADRG,0)) Q:'PSASYN!('$D(^PSDRUG(PSADRG,1,PSASYN,0)))
  1. S PSAVSN=$P(^PSDRUG(PSADRG,1,PSASYN,0),"^",4),PSAOU=$S(+$P(^(0),"^",5):$P($G(^DIC(51.5,+$P(^(0),"^",5),0)),"^"),1:"")
  1. S PSADUOU=$S(+$P(^PSDRUG(PSADRG,1,PSASYN,0),"^",7):+$P(^(0),"^",7),1:""),PSADU=$P($G(^PSDRUG(PSADRG,660)),"^",8)
  1. Q:PSAVSN=""
  1. S PSALVSN="VSN: "_PSAVSN I PSAOU'="",+PSADUOU,PSADU'="" S PSALVSN=PSALVSN_" "_PSADUOU_" "_PSADU_"/"_PSAOU
  1. K PSASYN,PSAVSN,PSAOU,PSADUOU,PSADU
  1. Q
  1. SETMSG ;Creates the body of the mail message.
  1. I PSAFIRST D
  1. .I PSACNT'=0 S PSACNT=PSACNT+1,^TMP("PSAMSGO",$J,PSACNT)="=============================================================================",PSACNT=PSACNT+1,^TMP("PSAMSGO",$J,PSACNT)=" "
  1. .K PSALOCA D SITES^PSAUTL1 S PSALOCA($P(^PSD(58.8,PSALOC,0),"^")_PSACOMB,PSALOC)=PSAISIT_"^"_PSAOSIT,PSALOCN=$O(PSALOCA("")),PSAFIRST=0
  1. .S PSACNT=PSACNT+1,PSACNT(PSACNT)=$S($P(^PSD(58.8,PSALOC,0),"^",2)="P":"PHARMACY LOCATION",1:"MASTER VAULT")
  1. .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)
  1. .I $L(PSALOCN)<77 S PSACNT=PSACNT+1,^TMP("PSAMSGO",$J,PSACNT)=PSALOCN
  1. .S PSACNT=PSACNT+1,^TMP("PSAMSGO",$J,PSACNT)=" Stock Current Amount to"
  1. .S PSACNT=PSACNT+1,^TMP("PSAMSGO",$J,PSACNT)="Drug Name: Level Balance Order"
  1. .S PSACNT=PSACNT+1,^TMP("PSAMSGO",$J,PSACNT)="-----------------------------------------------------------------------------"
  1. S PSALEN=$L(PSADRG),PSASPACE=$E(" ",1,(42-PSALEN))
  1. 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")
  1. S PSACNT=PSACNT+1 S:$G(PSAVSN)'="" ^TMP("PSAMSGO",$J,PSACNT)=" "_PSAVSN
  1. Q
  1. ;
  1. EXIT ;Kills the variables & TMP globals.
  1. K ^TMP("PSAMSGO",$J),^TMP("PSAORD",$J),^TMP("PSAORDCS",$J)
  1. K PSA,PSABAL,PSACNT,PSACOMB,PSADRG,PSAFIRST,PSAISIT,PSALEN,PSALOC,PSALOCA,PSALOCN,PSANODE,PSAOSIT,PSAISITN,PSAOSITN,PSASPACE,PSASTOCK,XMDUZ,XMSUB,XMTEXT,XMY
  1. Q