PSAVER6 ;BIR/JMB-Verify Invoices - CONT'D ;10/3/97
;;3.0;DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**1,3,21,42,53,57,61,64,76**; 10/24/97;Build 1
;Background Job:
;References to ^PSDRUG( are covered by IA #2095
;This routine increments pharmacy location and master vault balances
;in 58.8 after invoices have been verified.
;
START ;|=> *42 add Post Verify variance report
K ^TMP($J,"PSADD")
K DIC,DA,DR,DIE ;|=> *52 MOVE POST VERIFY E-MAIL LOGIC FROM START+17
S PSAIEN=0 F S PSAIEN=+$O(PSAVBKG(PSAIEN)) Q:'PSAIEN D
.Q:'$D(^PSD(58.811,PSAIEN,0))
.S PSAORD=$P(^PSD(58.811,PSAIEN,0),"^"),PSAVEND=$P(^(0),"^",2),PSAIEN1=0
.F S PSAIEN1=+$O(PSAVBKG(PSAIEN,PSAIEN1)) Q:'PSAIEN1 D
..Q:'$D(^PSD(58.811,PSAIEN,1,PSAIEN1,0))
..D SCANDIF ; *57 <=|
S PSAIEN=0 F S PSAIEN=+$O(PSAVBKG(PSAIEN)) Q:'PSAIEN D
.Q:'$D(^PSD(58.811,PSAIEN,0))
.S PSAORD=$P(^PSD(58.811,PSAIEN,0),"^"),PSAVEND=$P(^(0),"^",2),PSAIEN1=0
.F S PSAIEN1=+$O(PSAVBKG(PSAIEN,PSAIEN1)) Q:'PSAIEN1 D
..Q:'$D(^PSD(58.811,PSAIEN,1,PSAIEN1,0))
..S PSAIN=^PSD(58.811,PSAIEN,1,PSAIEN1,0)
..K DIC,DA,DR,DIE
..I +$P(PSAIN,"^",13) K DA S DIE="^PSD(58.811,"_PSAIEN_",1,",DA(1)=PSAIEN,DA=PSAIEN1,DR="2////C" D ^DIE K DIE,DA,DR Q
..S PSAINV=$P(PSAIN,"^"),PSAINVDT=$P(PSAIN,"^",2),PSALINE=0
..F S PSALINE=+$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE)) Q:'PSALINE D
...Q:'$D(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,0))
...S PSADATA=^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,0) D GETDATA I 'PSASUP,'$D(PSA0QTY) D FILE ;PSA*3*42
..K DIC,DA,DR,DIE
..K DA S DIE="^PSD(58.811,"_PSAIEN_",1,",DA(1)=PSAIEN,DA=PSAIEN1,DR="2////C" D ^DIE K DIE,DA,DR
;;*57 => START+17 THRU START+22 MOVED TO START+3 <=|
; *42 <=|
EXIT ;Kills variables
K %,DA,DD,DIC,DIE,DINUM,DLAYGO,DO,PSA,PSAA,PSABAL,PSACBAL,PSACNT,PSACNT,PSACOD,PSACOST,PSACS,PSADASH,PSADATA,PSADJ,PSADJD,PSADJO,PSADJP,PSADJQ
K PSADRG,PSADT,PSADUOU,PSADUQTY,PSADUREC,PSAIEN,PSAIEN1,PSAIN,PSAINV,PSAINVDT,PSALEN,PSALINE,PSALOC,PSAMSG,PSANDC,PSANODE,PSANPDU,PSANPOU
K PSAODASH,PSAONDC,PSAORD,PSAOU,PSAPDU,PSAPOU,PSAQTY,PSAREORD,PSASET,PSASTOCK,PSASUP,PSAT,PSATDRG,PSATEMP,PSAVBKG,PSAVDUZ,PSAVEND,PSAVSN,X,XMDUZ,XMSUB,XMTEXT,XMY,XMZ,Y
K PSA0QTY
Q
;
GETDATA ;Gets invoice data to help file the data
S PSAVDUZ=$P(PSADATA,"^",9),PSASUP=0 K PSA0QTY ;; <<RJS-3*76??
S PSADJ=+$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","D",0))
I '$G(PSADJ) S PSADRG=$S(+$P(PSADATA,"^",2):+$P(PSADATA,"^",2),1:0) G CS
I $G(PSADJ) D
.S PSANODE=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ,0))
.S PSADJD=$S($P(PSANODE,"^",6)'="":$P(PSANODE,"^",6),1:$P(PSANODE,"^",2))
.I PSADJD'?1.N S PSASUP=1
.S PSADRG=$S(PSADJ&('PSASUP):+PSADJD,PSADJ&(PSASUP):0,1:+$P(PSADATA,"^",2))
.I +PSADJD,$L(PSADJD)=$L(+PSADJD),$P($G(^PSDRUG(+PSADJD,0)),"^")'="" S PSADRG=+PSADJD Q
.I +PSADJD,$L(PSADJD)=$L(+PSADJD),$P($G(^PSDRUG(+PSADJD,0)),"^")="" S (PSADJ,PSADRG)=0 Q
CS Q:PSASUP!('PSADRG)
S PSACS=$S(+$P(PSADATA,"^",10):1,1:0)
S PSADJQ=0,PSADJ=+$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","Q",0))
I $G(PSADJ) S PSANODE=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ,0)),PSADJQ=$S($P(PSANODE,"^",6)'="":+$P(PSANODE,"^",6),1:$P(PSANODE,"^",2))
;
;PSA*3*1 (DAVE B)
S PSAQTY=$S(($G(PSADJQ)'=""&(+PSADJ)):PSADJQ,1:+$P(PSADATA,"^",3))
S PSAOU=$S(+$P(PSADATA,"^",4):+$P(PSADATA,"^",4),1:"")
;
;DAVE B (PSA*3*3)
;I +$P($P($G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,2)),"^",5),"~",2) S PSAOU=$P($P($G(^(2)),"^",5),"~",2)
;
S PSADJO=0,PSADJ=+$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","O",0))
I $G(PSADJ) S PSANODE=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ,0)),PSADJO=$S($P(PSANODE,"^",6)'="":$P(PSANODE,"^",6),1:$P(PSANODE,"^",2))
S:$G(PSADJO) PSAOU=$G(PSADJO)
S PSANDC=$P(PSADATA,"^",11) D PSANDC1^PSAHELP S PSADASH=PSANDCX K PSANDCX
S PSADJP=0,PSADJ=+$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","P",0))
I $G(PSADJ) S PSANODE=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ,0)),PSADJP=$S(+$P(PSANODE,"^",6):+$P(PSANODE,"^",6),1:+$P(PSANODE,"^",2))
S (PSAPOU,PSANPOU)=$S($G(PSADJP):PSADJP,1:+$P(PSADATA,"^",5)),PSALEN=$L($P(PSANPOU,".")),(PSAPOU,PSANPOU)=$J(PSANPOU,PSALEN,2)
S PSAVSN=$P(PSADATA,"^",12)
S PSALOC=$S(+PSACS:+$P(PSAIN,"^",12),1:+$P(PSAIN,"^",5))
TEMP S PSATEMP=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,2))
S PSADUOU=+$P(PSATEMP,"^"),PSAREORD=+$P(PSATEMP,"^",2),PSASUB=+$P(PSATEMP,"^",3),PSASTOCK=+$P(PSATEMP,"^",4)
S PSADUOU=$S(+PSADUOU:+PSADUOU,+PSASUB&(+$P($G(^PSDRUG(PSADRG,1,PSASUB,0)),"^",7)):+$P($G(^PSDRUG(PSADRG,1,PSASUB,0)),"^",7),1:1)
S PSADUREC=$S(PSADUOU:PSAQTY*PSADUOU,1:0)
;
;DAVE B (18NOV98)
I PSADUREC=0,$D(PSAQTY),$P($G(^PSDRUG(PSADRG,660)),"^",5)'="" S PSADUREC=(PSAQTY*($P(^PSDRUG(PSADRG,660),"^",5)))
Q:'+$P($G(^PSD(58.8,PSALOC,0)),"^",14)
S PSAREORD=$S(+PSAREORD:+PSAREORD,+$P($G(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",5):+$P($G(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",5),1:0)
S PSASTOCK=$S(+PSASTOCK:+PSASTOCK,+$P($G(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",3):+$P($G(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",3),1:0)
K PSA0QTY I '$G(PSAQTY),'$G(PSADJQ) S PSA0QTY=1 Q ;PSA*3*42 (0 QTY)
Q
;
FILE ;File data in 58.8
I $D(PSADUREC),PSADUREC'>0 S PSADUREC=$S($D(PSADJQ):PSADJQ,$D(PSAQTY):PSAQTY,1:0)
D NOW^%DTC S PSADT=+$E(%,1,14)
I '$D(^PSD(58.8,PSALOC,1,PSADRG,0)) D
.K DIC,DA,DR,DIE
.S:'$D(^PSD(58.8,PSALOC,1,0)) DIC("P")=$P(^DD(58.8,10,0),"^",2)
.S DA(1)=PSALOC,DIC="^PSD(58.8,"_DA(1)_",1,",(DA,DINUM,X)=PSADRG,DIC(0)="L",DLAYGO=58.8
.F L +^PSD(58.8,PSALOC,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
.D FILE^DICN L -^PSD(58.8,PSALOC,0) K DIC,DA,DLAYGO
.D MM ;*42 send mailmessage
F L +^PSD(58.8,PSALOC,1,PSADRG,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
S PSABAL=+$P($G(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",4)
;
;DAVE B (PSA*3*3)
I $P($G(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",1)'=PSADRG S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",1)=PSADRG
S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",4)=PSADUREC+PSABAL
I +$P($G(^PSD(58.8,PSALOC,0)),"^",14) D
.I PSASTOCK'=$P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",3) S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",3)=PSASTOCK
.I PSAREORD'=$P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",5) S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",5)=PSAREORD
S:'$D(^PSD(58.8,PSALOC,1,PSADRG,5,0)) DIC("P")=$P(^DD(58.8001,20,0),"^",2)
I '$D(^PSD(58.8,PSALOC,1,PSADRG,5,$E(DT,1,5)*100,0)) D
.K DIC,DA,DR,DIE
.S DIC="^PSD(58.8,"_PSALOC_",1,"_PSADRG_",5,",DIC(0)="L",DIC("DR")="1////^S X=$G(PSABAL)"
.S (X,DINUM)=$E(DT,1,5)*100,DA(2)=PSALOC,DA(1)=PSADRG,DLAYGO=58.8 D ^DIC K DIC("DR")
.S X="T-1M" D ^%DT S (X,DINUM)=$E(Y,1,5)*100,DA=PSADRG D ^DIC K DIC,DLAYGO
.K DIC,DA,DR,DIE
.S DA=+Y,DA(2)=PSALOC,DA(1)=PSADRG,DIE="^PSD(58.8,"_DA(2)_",1,"_DA(1)_",5,",DR="3////^S X=$G(PSABAL)" D ^DIE K DIE
K DIC,DA,DR,DIE
S DA=$E(DT,1,5)*100
S DA(2)=PSALOC,DA(1)=PSADRG,DIE="^PSD(58.8,"_DA(2)_",1,"_DA(1)_",5,",DA=$E(DT,1,5)*100,DR="3////^S X=($G(PSABAL)+$G(PSADUREC));5////^S X="_($P($G(^(0)),"^",3)+PSADUREC) D ^DIE K DIE
L -^PSD(58.8,PSALOC,1,PSADRG,0)
G TR^PSAVER7
MM ;
;*42 Mail Message to holders of PSDMGR, PSAMGR key
;*53 Consolidate messages
N PSACS S PSACS=$S($$GET1^DIQ(50,PSADRG,63)["N":" Controlled Substance ",1:"")
S ^TMP($J,"PSADD",$$GET1^DIQ(58.8,PSALOC,.01),$$GET1^DIQ(50,PSADRG,.01))=""
Q
SCANDIF ;*42 inspect invoice for noted differences in OU,DUOU,PPDU,NDC
;NEEDS PSAIEN, PSAIEN1
K ^TMP($J,"PSADIF"),PSADIFLC
S PSALINE=0 F S PSALINE=$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE)) Q:PSALINE'>0 D CHECK^PSAPROC7 ;checks and stores differences in ^TMP($J,
I $D(^TMP($J,"PSADD")) D ADDMM
I $D(^TMP($J,"PSADIF")) D MESSAGE
Q
MESSAGE ;differences found, notify user and send message to g.PSA NDC UPDATES.
K DIR N IENS
S PSAORD=$$GET1^DIQ(58.811,PSAIEN,.01),IENS=PSAIEN1_","_PSAIEN
S PSAINV=$$GET1^DIQ(58.8112,IENS,.01)
S XMSUB="POST Verify Variance Report Ord: "_PSAORD_" Inv: "_PSAINV ;*52
S ^TMP($J,"PSADIF",1,0)=XMSUB,^TMP($J,"PSADIF",2,0)=" "
S XMTEXT="^TMP($J,""PSADIF"",",XMY("G.PSA NDC UPDATES")=""
S XMDUZ="Price & NDC Updater"
D ^XMD
K PSADIFLC,^TMP($J,"PSADIF")
Q
ADDMM ; SEND MESSAGE REGARDING DRUGS ADDED TO PHARMACY LOCATIONS
K ^TMP($J,"PSADDMM")
S XMSUB="New Drugs Added by Order: "_$G(PSAORD)_" Invoice: "_$G(PSAINV)
S XMDUZ="Verified by: "_$$GET1^DIQ(200,DUZ,.01)
S LC=0,X=XMSUB D MMLINE S X=XMDUZ D MMLINE
S X="Please use DA and CS menus to populate the balances, stock and re-order levels." D MMLINE
S PSALOC="" F S PSALOC=$O(^TMP($J,"PSADD",PSALOC)) Q:PSALOC="" D
. S X=PSALOC D MMLINE
. S PSADRG="" F S PSADRG=$O(^TMP($J,"PSADD",PSALOC,PSADRG)) Q:PSADRG="" S X=" "_PSADRG D MMLINE
S XMTEXT="^TMP($J,""PSADDMM"","
S XMY("G.PSA NDC UPDATES")=""
D ^XMD
K ^TMP($J,"PSADD"),^TMP($J,"PSADDMM"),LC
Q
MMLINE S LC=LC+1,^TMP($J,"PSADDMM",LC,0)=X W !,X Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSAVER6 8812 printed Sep 23, 2025@19:27:09 Page 2
PSAVER6 ;BIR/JMB-Verify Invoices - CONT'D ;10/3/97
+1 ;;3.0;DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**1,3,21,42,53,57,61,64,76**; 10/24/97;Build 1
+2 ;Background Job:
+3 ;References to ^PSDRUG( are covered by IA #2095
+4 ;This routine increments pharmacy location and master vault balances
+5 ;in 58.8 after invoices have been verified.
+6 ;
START ;|=> *42 add Post Verify variance report
+1 KILL ^TMP($JOB,"PSADD")
+2 ;|=> *52 MOVE POST VERIFY E-MAIL LOGIC FROM START+17
KILL DIC,DA,DR,DIE
+3 SET PSAIEN=0
FOR
SET PSAIEN=+$ORDER(PSAVBKG(PSAIEN))
if 'PSAIEN
QUIT
Begin DoDot:1
+4 if '$DATA(^PSD(58.811,PSAIEN,0))
QUIT
+5 SET PSAORD=$PIECE(^PSD(58.811,PSAIEN,0),"^")
SET PSAVEND=$PIECE(^(0),"^",2)
SET PSAIEN1=0
+6 FOR
SET PSAIEN1=+$ORDER(PSAVBKG(PSAIEN,PSAIEN1))
if 'PSAIEN1
QUIT
Begin DoDot:2
+7 if '$DATA(^PSD(58.811,PSAIEN,1,PSAIEN1,0))
QUIT
+8 ; *57 <=|
DO SCANDIF
End DoDot:2
End DoDot:1
+9 SET PSAIEN=0
FOR
SET PSAIEN=+$ORDER(PSAVBKG(PSAIEN))
if 'PSAIEN
QUIT
Begin DoDot:1
+10 if '$DATA(^PSD(58.811,PSAIEN,0))
QUIT
+11 SET PSAORD=$PIECE(^PSD(58.811,PSAIEN,0),"^")
SET PSAVEND=$PIECE(^(0),"^",2)
SET PSAIEN1=0
+12 FOR
SET PSAIEN1=+$ORDER(PSAVBKG(PSAIEN,PSAIEN1))
if 'PSAIEN1
QUIT
Begin DoDot:2
+13 if '$DATA(^PSD(58.811,PSAIEN,1,PSAIEN1,0))
QUIT
+14 SET PSAIN=^PSD(58.811,PSAIEN,1,PSAIEN1,0)
+15 KILL DIC,DA,DR,DIE
+16 IF +$PIECE(PSAIN,"^",13)
KILL DA
SET DIE="^PSD(58.811,"_PSAIEN_",1,"
SET DA(1)=PSAIEN
SET DA=PSAIEN1
SET DR="2////C"
DO ^DIE
KILL DIE,DA,DR
QUIT
+17 SET PSAINV=$PIECE(PSAIN,"^")
SET PSAINVDT=$PIECE(PSAIN,"^",2)
SET PSALINE=0
+18 FOR
SET PSALINE=+$ORDER(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE))
if 'PSALINE
QUIT
Begin DoDot:3
+19 if '$DATA(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,0))
QUIT
+20 ;PSA*3*42
SET PSADATA=^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,0)
DO GETDATA
IF 'PSASUP
IF '$DATA(PSA0QTY)
DO FILE
End DoDot:3
+21 KILL DIC,DA,DR,DIE
+22 KILL DA
SET DIE="^PSD(58.811,"_PSAIEN_",1,"
SET DA(1)=PSAIEN
SET DA=PSAIEN1
SET DR="2////C"
DO ^DIE
KILL DIE,DA,DR
End DoDot:2
End DoDot:1
+23 ;;*57 => START+17 THRU START+22 MOVED TO START+3 <=|
+24 ; *42 <=|
EXIT ;Kills variables
+1 KILL %,DA,DD,DIC,DIE,DINUM,DLAYGO,DO,PSA,PSAA,PSABAL,PSACBAL,PSACNT,PSACNT,PSACOD,PSACOST,PSACS,PSADASH,PSADATA,PSADJ,PSADJD,PSADJO,PSADJP,PSADJQ
+2 KILL PSADRG,PSADT,PSADUOU,PSADUQTY,PSADUREC,PSAIEN,PSAIEN1,PSAIN,PSAINV,PSAINVDT,PSALEN,PSALINE,PSALOC,PSAMSG,PSANDC,PSANODE,PSANPDU,PSANPOU
+3 KILL PSAODASH,PSAONDC,PSAORD,PSAOU,PSAPDU,PSAPOU,PSAQTY,PSAREORD,PSASET,PSASTOCK,PSASUP,PSAT,PSATDRG,PSATEMP,PSAVBKG,PSAVDUZ,PSAVEND,PSAVSN,X,XMDUZ,XMSUB,XMTEXT,XMY,XMZ,Y
+4 KILL PSA0QTY
+5 QUIT
+6 ;
GETDATA ;Gets invoice data to help file the data
+1 ;; <<RJS-3*76??
SET PSAVDUZ=$PIECE(PSADATA,"^",9)
SET PSASUP=0
KILL PSA0QTY
+2 SET PSADJ=+$ORDER(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","D",0))
+3 IF '$GET(PSADJ)
SET PSADRG=$SELECT(+$PIECE(PSADATA,"^",2):+$PIECE(PSADATA,"^",2),1:0)
GOTO CS
+4 IF $GET(PSADJ)
Begin DoDot:1
+5 SET PSANODE=$GET(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ,0))
+6 SET PSADJD=$SELECT($PIECE(PSANODE,"^",6)'="":$PIECE(PSANODE,"^",6),1:$PIECE(PSANODE,"^",2))
+7 IF PSADJD'?1.N
SET PSASUP=1
+8 SET PSADRG=$SELECT(PSADJ&('PSASUP):+PSADJD,PSADJ&(PSASUP):0,1:+$PIECE(PSADATA,"^",2))
+9 IF +PSADJD
IF $LENGTH(PSADJD)=$LENGTH(+PSADJD)
IF $PIECE($GET(^PSDRUG(+PSADJD,0)),"^")'=""
SET PSADRG=+PSADJD
QUIT
+10 IF +PSADJD
IF $LENGTH(PSADJD)=$LENGTH(+PSADJD)
IF $PIECE($GET(^PSDRUG(+PSADJD,0)),"^")=""
SET (PSADJ,PSADRG)=0
QUIT
End DoDot:1
CS if PSASUP!('PSADRG)
QUIT
+1 SET PSACS=$SELECT(+$PIECE(PSADATA,"^",10):1,1:0)
+2 SET PSADJQ=0
SET PSADJ=+$ORDER(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","Q",0))
+3 IF $GET(PSADJ)
SET PSANODE=$GET(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ,0))
SET PSADJQ=$SELECT($PIECE(PSANODE,"^",6)'="":+$PIECE(PSANODE,"^",6),1:$PIECE(PSANODE,"^",2))
+4 ;
+5 ;PSA*3*1 (DAVE B)
+6 SET PSAQTY=$SELECT(($GET(PSADJQ)'=""&(+PSADJ)):PSADJQ,1:+$PIECE(PSADATA,"^",3))
+7 SET PSAOU=$SELECT(+$PIECE(PSADATA,"^",4):+$PIECE(PSADATA,"^",4),1:"")
+8 ;
+9 ;DAVE B (PSA*3*3)
+10 ;I +$P($P($G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,2)),"^",5),"~",2) S PSAOU=$P($P($G(^(2)),"^",5),"~",2)
+11 ;
+12 SET PSADJO=0
SET PSADJ=+$ORDER(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","O",0))
+13 IF $GET(PSADJ)
SET PSANODE=$GET(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ,0))
SET PSADJO=$SELECT($PIECE(PSANODE,"^",6)'="":$PIECE(PSANODE,"^",6),1:$PIECE(PSANODE,"^",2))
+14 if $GET(PSADJO)
SET PSAOU=$GET(PSADJO)
+15 SET PSANDC=$PIECE(PSADATA,"^",11)
DO PSANDC1^PSAHELP
SET PSADASH=PSANDCX
KILL PSANDCX
+16 SET PSADJP=0
SET PSADJ=+$ORDER(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","P",0))
+17 IF $GET(PSADJ)
SET PSANODE=$GET(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ,0))
SET PSADJP=$SELECT(+$PIECE(PSANODE,"^",6):+$PIECE(PSANODE,"^",6),1:+$PIECE(PSANODE,"^",2))
+18 SET (PSAPOU,PSANPOU)=$SELECT($GET(PSADJP):PSADJP,1:+$PIECE(PSADATA,"^",5))
SET PSALEN=$LENGTH($PIECE(PSANPOU,"."))
SET (PSAPOU,PSANPOU)=$JUSTIFY(PSANPOU,PSALEN,2)
+19 SET PSAVSN=$PIECE(PSADATA,"^",12)
+20 SET PSALOC=$SELECT(+PSACS:+$PIECE(PSAIN,"^",12),1:+$PIECE(PSAIN,"^",5))
TEMP SET PSATEMP=$GET(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,2))
+1 SET PSADUOU=+$PIECE(PSATEMP,"^")
SET PSAREORD=+$PIECE(PSATEMP,"^",2)
SET PSASUB=+$PIECE(PSATEMP,"^",3)
SET PSASTOCK=+$PIECE(PSATEMP,"^",4)
+2 SET PSADUOU=$SELECT(+PSADUOU:+PSADUOU,+PSASUB&(+$PIECE($GET(^PSDRUG(PSADRG,1,PSASUB,0)),"^",7)):+$PIECE($GET(^PSDRUG(PSADRG,1,PSASUB,0)),"^",7),1:1)
+3 SET PSADUREC=$SELECT(PSADUOU:PSAQTY*PSADUOU,1:0)
+4 ;
+5 ;DAVE B (18NOV98)
+6 IF PSADUREC=0
IF $DATA(PSAQTY)
IF $PIECE($GET(^PSDRUG(PSADRG,660)),"^",5)'=""
SET PSADUREC=(PSAQTY*($PIECE(^PSDRUG(PSADRG,660),"^",5)))
+7 if '+$PIECE($GET(^PSD(58.8,PSALOC,0)),"^",14)
QUIT
+8 SET PSAREORD=$SELECT(+PSAREORD:+PSAREORD,+$PIECE($GET(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",5):+$PIECE($GET(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",5),1:0)
+9 SET PSASTOCK=$SELECT(+PSASTOCK:+PSASTOCK,+$PIECE($GET(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",3):+$PIECE($GET(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",3),1:0)
+10 ;PSA*3*42 (0 QTY)
KILL PSA0QTY
IF '$GET(PSAQTY)
IF '$GET(PSADJQ)
SET PSA0QTY=1
QUIT
+11 QUIT
+12 ;
FILE ;File data in 58.8
+1 IF $DATA(PSADUREC)
IF PSADUREC'>0
SET PSADUREC=$SELECT($DATA(PSADJQ):PSADJQ,$DATA(PSAQTY):PSAQTY,1:0)
+2 DO NOW^%DTC
SET PSADT=+$EXTRACT(%,1,14)
+3 IF '$DATA(^PSD(58.8,PSALOC,1,PSADRG,0))
Begin DoDot:1
+4 KILL DIC,DA,DR,DIE
+5 if '$DATA(^PSD(58.8,PSALOC,1,0))
SET DIC("P")=$PIECE(^DD(58.8,10,0),"^",2)
+6 SET DA(1)=PSALOC
SET DIC="^PSD(58.8,"_DA(1)_",1,"
SET (DA,DINUM,X)=PSADRG
SET DIC(0)="L"
SET DLAYGO=58.8
+7 FOR
LOCK +^PSD(58.8,PSALOC,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+8 DO FILE^DICN
LOCK -^PSD(58.8,PSALOC,0)
KILL DIC,DA,DLAYGO
+9 ;*42 send mailmessage
DO MM
End DoDot:1
+10 FOR
LOCK +^PSD(58.8,PSALOC,1,PSADRG,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+11 SET PSABAL=+$PIECE($GET(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",4)
+12 ;
+13 ;DAVE B (PSA*3*3)
+14 IF $PIECE($GET(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",1)'=PSADRG
SET $PIECE(^PSD(58.8,PSALOC,1,PSADRG,0),"^",1)=PSADRG
+15 SET $PIECE(^PSD(58.8,PSALOC,1,PSADRG,0),"^",4)=PSADUREC+PSABAL
+16 IF +$PIECE($GET(^PSD(58.8,PSALOC,0)),"^",14)
Begin DoDot:1
+17 IF PSASTOCK'=$PIECE(^PSD(58.8,PSALOC,1,PSADRG,0),"^",3)
SET $PIECE(^PSD(58.8,PSALOC,1,PSADRG,0),"^",3)=PSASTOCK
+18 IF PSAREORD'=$PIECE(^PSD(58.8,PSALOC,1,PSADRG,0),"^",5)
SET $PIECE(^PSD(58.8,PSALOC,1,PSADRG,0),"^",5)=PSAREORD
End DoDot:1
+19 if '$DATA(^PSD(58.8,PSALOC,1,PSADRG,5,0))
SET DIC("P")=$PIECE(^DD(58.8001,20,0),"^",2)
+20 IF '$DATA(^PSD(58.8,PSALOC,1,PSADRG,5,$EXTRACT(DT,1,5)*100,0))
Begin DoDot:1
+21 KILL DIC,DA,DR,DIE
+22 SET DIC="^PSD(58.8,"_PSALOC_",1,"_PSADRG_",5,"
SET DIC(0)="L"
SET DIC("DR")="1////^S X=$G(PSABAL)"
+23 SET (X,DINUM)=$EXTRACT(DT,1,5)*100
SET DA(2)=PSALOC
SET DA(1)=PSADRG
SET DLAYGO=58.8
DO ^DIC
KILL DIC("DR")
+24 SET X="T-1M"
DO ^%DT
SET (X,DINUM)=$EXTRACT(Y,1,5)*100
SET DA=PSADRG
DO ^DIC
KILL DIC,DLAYGO
+25 KILL DIC,DA,DR,DIE
+26 SET DA=+Y
SET DA(2)=PSALOC
SET DA(1)=PSADRG
SET DIE="^PSD(58.8,"_DA(2)_",1,"_DA(1)_",5,"
SET DR="3////^S X=$G(PSABAL)"
DO ^DIE
KILL DIE
End DoDot:1
+27 KILL DIC,DA,DR,DIE
+28 SET DA=$EXTRACT(DT,1,5)*100
+29 SET DA(2)=PSALOC
SET DA(1)=PSADRG
SET DIE="^PSD(58.8,"_DA(2)_",1,"_DA(1)_",5,"
SET DA=$EXTRACT(DT,1,5)*100
SET DR="3////^S X=($G(PSABAL)+$G(PSADUREC));5////^S X="_($PIECE($GET(^(0)),"^",3)+PSADUREC)
DO ^DIE
KILL DIE
+30 LOCK -^PSD(58.8,PSALOC,1,PSADRG,0)
+31 GOTO TR^PSAVER7
MM ;
+1 ;*42 Mail Message to holders of PSDMGR, PSAMGR key
+2 ;*53 Consolidate messages
+3 NEW PSACS
SET PSACS=$SELECT($$GET1^DIQ(50,PSADRG,63)["N":" Controlled Substance ",1:"")
+4 SET ^TMP($JOB,"PSADD",$$GET1^DIQ(58.8,PSALOC,.01),$$GET1^DIQ(50,PSADRG,.01))=""
+5 QUIT
SCANDIF ;*42 inspect invoice for noted differences in OU,DUOU,PPDU,NDC
+1 ;NEEDS PSAIEN, PSAIEN1
+2 KILL ^TMP($JOB,"PSADIF"),PSADIFLC
+3 ;checks and stores differences in ^TMP($J,
SET PSALINE=0
FOR
SET PSALINE=$ORDER(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE))
if PSALINE'>0
QUIT
DO CHECK^PSAPROC7
+4 IF $DATA(^TMP($JOB,"PSADD"))
DO ADDMM
+5 IF $DATA(^TMP($JOB,"PSADIF"))
DO MESSAGE
+6 QUIT
MESSAGE ;differences found, notify user and send message to g.PSA NDC UPDATES.
+1 KILL DIR
NEW IENS
+2 SET PSAORD=$$GET1^DIQ(58.811,PSAIEN,.01)
SET IENS=PSAIEN1_","_PSAIEN
+3 SET PSAINV=$$GET1^DIQ(58.8112,IENS,.01)
+4 ;*52
SET XMSUB="POST Verify Variance Report Ord: "_PSAORD_" Inv: "_PSAINV
+5 SET ^TMP($JOB,"PSADIF",1,0)=XMSUB
SET ^TMP($JOB,"PSADIF",2,0)=" "
+6 SET XMTEXT="^TMP($J,""PSADIF"","
SET XMY("G.PSA NDC UPDATES")=""
+7 SET XMDUZ="Price & NDC Updater"
+8 DO ^XMD
+9 KILL PSADIFLC,^TMP($JOB,"PSADIF")
+10 QUIT
ADDMM ; SEND MESSAGE REGARDING DRUGS ADDED TO PHARMACY LOCATIONS
+1 KILL ^TMP($JOB,"PSADDMM")
+2 SET XMSUB="New Drugs Added by Order: "_$GET(PSAORD)_" Invoice: "_$GET(PSAINV)
+3 SET XMDUZ="Verified by: "_$$GET1^DIQ(200,DUZ,.01)
+4 SET LC=0
SET X=XMSUB
DO MMLINE
SET X=XMDUZ
DO MMLINE
+5 SET X="Please use DA and CS menus to populate the balances, stock and re-order levels."
DO MMLINE
+6 SET PSALOC=""
FOR
SET PSALOC=$ORDER(^TMP($JOB,"PSADD",PSALOC))
if PSALOC=""
QUIT
Begin DoDot:1
+7 SET X=PSALOC
DO MMLINE
+8 SET PSADRG=""
FOR
SET PSADRG=$ORDER(^TMP($JOB,"PSADD",PSALOC,PSADRG))
if PSADRG=""
QUIT
SET X=" "_PSADRG
DO MMLINE
End DoDot:1
+9 SET XMTEXT="^TMP($J,""PSADDMM"","
+10 SET XMY("G.PSA NDC UPDATES")=""
+11 DO ^XMD
+12 KILL ^TMP($JOB,"PSADD"),^TMP($JOB,"PSADDMM"),LC
+13 QUIT
MMLINE SET LC=LC+1
SET ^TMP($JOB,"PSADDMM",LC,0)=X
WRITE !,X
QUIT
