- 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
- 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