PSAVER7 ;BIR/JMB-Verify Invoices - CONT'D ;7/23/97
;;3.0;DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**12,21,42,56,64,66,76**; 10/24/97;Build 1
;Background Job
;This routine increments pharmacy location and master vault balances
;in 58.8 after invoices have been verified. This routine is called
;by PSAVER6.
;
;References to ^PSDRUG( are covered by IA #2095
TR ;File transaction data in 58.81
I $D(PSADUREC),'PSADUREC Q ;*56 block '0' quantity edits
I $D(PSAQTY),'PSAQTY Q ;*56 block '0' quantity edits
F L +^PSD(58.81,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
FIND S PSAT=$P(^PSD(58.81,0),"^",3)+1 I $D(^PSD(58.81,PSAT)) S $P(^PSD(58.81,0),"^",3)=$P(^PSD(58.81,0),"^",3)+1 G FIND
S DIC="^PSD(58.81,",DIC(0)="L",DLAYGO=58.81,(DINUM,X)=PSAT D ^DIC K DIC,DINUM,DLAYGO L -^PSD(58.81,0)
S DIE="^PSD(58.81,",DA=PSAT,DR="1////1;2////^S X=PSALOC;3////^S X=PSADT;4////^S X=PSADRG;5////^S X=PSADUREC;6////^S X=PSAVDUZ;9////^S X=PSABAL;71////^S X=PSAINV;106////^S X=PSAORD"
I $G(PSACS) S DR=DR_";100////^S X=PSACS"
F L +^PSD(58.81,DA,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
D ^DIE L -^PSD(58.81,DA,0) K DIE
S:'$D(^PSD(58.8,PSALOC,1,PSADRG,4,0)) DIC("P")=$P(^DD(58.8001,19,0),"^",2)
S DA(2)=PSALOC,DA(1)=PSADRG,(X,DINUM)=PSAT,DIC="^PSD(58.8,"_DA(2)_",1,"_DA(1)_",4,",DIC(0)="L",DLAYGO=58.8
F L +^PSD(58.8,PSALOC,1,PSADRG,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
D ^DIC L -^PSD(58.8,PSALOC,1,PSADRG,0) K DIC,DINUM,DLAYGO
;
50 S PSAODASH=$P($G(^PSDRUG(PSADRG,2)),"^",4)
S PSAONDC=$P(PSAODASH,"-")_$P(PSAODASH,"-",2)_$P(PSAODASH,"-",3)
;(PSA*3*21) NDC & PRICING UPDATES (DAVE BLOCKER 10NOV99)
S PSADUOU=$S($G(PSADUOU)'>0:1,1:PSADUOU)
S PSADUREC=(PSAQTY*PSADUOU)
S DIE="^PSDRUG(",DA=PSADRG,DR="50////^S X="_(PSADUREC+$G(^PSDRUG(PSADRG,660.1)))
F L +^PSDRUG(DA,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
D ^DIE L -^PSDRUG(DA,0) K DIE,DA,DR
;This section replaces most of the routine
;PSAOU = order unit from invoice
;PSAPOU & PSANPOU = Price of Order Unit from invoice
;PSADUOU=Dispense Units per OU form invoice data
;PSANPDU= Price of Dispense Units per Order Unit
;
;Drug file Information
K DRUG
S PSANODE=$G(^PSDRUG(PSADRG,660))
F X=2,3,5,6 S DRUG(X)=$P($G(PSANODE),"^",X)
;
S PSANPDU=$J(($G(PSAPOU)/$G(PSADUOU)),0,4) ;Price of Order Unit divide by Disp. Units per Order Unit
;PSA*3*42 |> (let changes happen and file, put changes into mail message)
S DIE="^PSDRUG(",(DA,OLDDA)=PSADRG,DR="12////^S X=PSAOU;15////^S X=PSADUOU;16///^S X=PSANPDU;13////^S X=PSAPOU" ;*42;*56;*76
F L +^PSDRUG(DA,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
D ^DIE K DIE,DA,DR
; <| PSA*42
PTCH21 ;PSA*3*21 (Vendor's VSN changing to 8 digits, check also)
;If NDC or VSN changes should it create to synonym entry ?
I $G(^PSDRUG(PSADRG,1,PSASUB,0))="" G NDC
I $G(^PSDRUG(PSADRG,1,PSASUB,0)) S PSAEDTT=0,DATA=^PSDRUG(PSADRG,1,PSASUB,0) D
.I PSAVSN'=$P(DATA,"^",4) S PSAEDTT=1 ;VSN
.I PSAPOU'=$P(DATA,"^",6) S PSAEDTT=1 ;Price per order unit
.I PSADUOU'=$P(DATA,"^",7) S PSAEDTT=1 ;Dispense Units per Order Unit
.I PSANPDU'=$P(DATA,"^",8) S PSAEDTT=1 ;New Price per dispense unit
.I $G(PSAEDTT)>0 D
..S DA=PSASUB,DA(1)=PSADRG,DIE="^PSDRUG("_DA(1)_",1,"
..S DR="2////^S X=PSADASH"_$S(PSACS:";1////C",1:";1////D")_";400////^S X=PSAVSN;401////^S X=PSAOU"_$S(+PSAPOU:";402////^S X=PSAPOU",1:"")_";403////^S X=PSADUOU"_";404///^S X=PSANPDU"_";405///^S X=PSAVEND"
..D ^DIE K DIE,DR,DA
NDC ;NDC UPDATE
I PSANDC'="",PSANDC'=PSAONDC D ;*42
.S DIE="^PSDRUG(",DA=PSADRG,DR="31////^S X=PSADASH"
.F L +^PSDRUG(DA,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
.D ^DIE L -^PSDRUG(DA,0) K DIE,DA,DR
SYNONYM ;Adds/edits the SYNONYM multiple in DRUG file >>*66 RJS
G:PSANDC="" END
S DA(1)=PSADRG ;; << *66 RJS
;
S PSANPDU=$J(($G(PSAPOU)/$G(PSADUOU)),0,4) ;Price of Order Unit divide by Disp. Units per Order Unit ;*76
S:'$D(^PSDRUG(PSADRG,1,0)) DIC("P")="50.1A"
; *56 Search for earliest best match of synonyms, start at bottom go up
; if VSN use it, if several VSNs use the first, IF VSN match NDCs must match also.
; if no VSN, make a new synonym
; no "B" synonym index exists
T0 N PSYNDA,PSYN0,PSTNDC,PSTVSN,PSMNDC,PSMBTH S (PSMNDC,PSMBTH)=0
S PSYNDA="" F S PSYNDA=$O(^PSDRUG(PSADRG,1,PSYNDA),-1) Q:PSYNDA'>0 D
. S PSYN0=^PSDRUG(PSADRG,1,PSYNDA,0),PSTNDC=$P(PSYN0,U),PSTVSN=$P(PSYN0,U,4) ;zero node, test values of NDC VSN
. I PSTNDC'=PSANDC Q
. I PSTVSN=PSAVSN S PSMBTH=PSYNDA Q ;both VSN & NDC matches
T1 S PSASUB=$S(PSMBTH:PSMBTH,1:0) ;PSAMBTH Match both vsn,ndc
;end *56
I 'PSASUB!(PSASUB&('$D(^PSDRUG(PSADRG,1,PSASUB,0)))) D
.S DIC="^PSDRUG("_DA(1)_",1,",DIC(0)="Z",X=PSANDC,DLAYGO=50
.F L +^PSDRUG(PSADRG,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
.D FILE^DICN L -^PSDRUG(PSADRG,0) K DIC,DLAYGO S PSASUB=+Y
.K DIC,DA,DR,DIE
I PSASUB,$D(^PSDRUG(PSADRG,1,PSASUB,0)) S DA=PSASUB
S DA(1)=PSADRG,DIE="^PSDRUG("_DA(1)_",1,"
S DR="2////^S X=PSADASH"_$S($G(PSACS)>0:";1////C",1:";1////D")_";400////^S X=PSAVSN;401////^S X=PSAOU"_$S(+PSAPOU:";402////^S X=PSAPOU",1:"")_";403////^S X=PSADUOU"_";404///^S X=PSANPDU;405///^S X=PSAVEND"
F L +^PSDRUG(PSADRG,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
D ^DIE L -^PSDRUG(PSADRG,0)
K DIE,DR,X1,X2,DATA
END ; FINAL CLEANUP << *66 RJS
L -^PSDRUG(OLDDA,0) K OLDDA ;; >> *66 RJS
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSAVER7 5338 printed Sep 23, 2025@19:27:10 Page 2
PSAVER7 ;BIR/JMB-Verify Invoices - CONT'D ;7/23/97
+1 ;;3.0;DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**12,21,42,56,64,66,76**; 10/24/97;Build 1
+2 ;Background Job
+3 ;This routine increments pharmacy location and master vault balances
+4 ;in 58.8 after invoices have been verified. This routine is called
+5 ;by PSAVER6.
+6 ;
+7 ;References to ^PSDRUG( are covered by IA #2095
TR ;File transaction data in 58.81
+1 ;*56 block '0' quantity edits
IF $DATA(PSADUREC)
IF 'PSADUREC
QUIT
+2 ;*56 block '0' quantity edits
IF $DATA(PSAQTY)
IF 'PSAQTY
QUIT
+3 FOR
LOCK +^PSD(58.81,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
FIND SET PSAT=$PIECE(^PSD(58.81,0),"^",3)+1
IF $DATA(^PSD(58.81,PSAT))
SET $PIECE(^PSD(58.81,0),"^",3)=$PIECE(^PSD(58.81,0),"^",3)+1
GOTO FIND
+1 SET DIC="^PSD(58.81,"
SET DIC(0)="L"
SET DLAYGO=58.81
SET (DINUM,X)=PSAT
DO ^DIC
KILL DIC,DINUM,DLAYGO
LOCK -^PSD(58.81,0)
+2 SET DIE="^PSD(58.81,"
SET DA=PSAT
SET DR="1////1;2////^S X=PSALOC;3////^S X=PSADT;4////^S X=PSADRG;5////^S X=PSADUREC;6////^S X=PSAVDUZ;9////^S X=PSABAL;71////^S X=PSAINV;106////^S X=PSAORD"
+3 IF $GET(PSACS)
SET DR=DR_";100////^S X=PSACS"
+4 FOR
LOCK +^PSD(58.81,DA,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+5 DO ^DIE
LOCK -^PSD(58.81,DA,0)
KILL DIE
+6 if '$DATA(^PSD(58.8,PSALOC,1,PSADRG,4,0))
SET DIC("P")=$PIECE(^DD(58.8001,19,0),"^",2)
+7 SET DA(2)=PSALOC
SET DA(1)=PSADRG
SET (X,DINUM)=PSAT
SET DIC="^PSD(58.8,"_DA(2)_",1,"_DA(1)_",4,"
SET DIC(0)="L"
SET DLAYGO=58.8
+8 FOR
LOCK +^PSD(58.8,PSALOC,1,PSADRG,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+9 DO ^DIC
LOCK -^PSD(58.8,PSALOC,1,PSADRG,0)
KILL DIC,DINUM,DLAYGO
+10 ;
50 SET PSAODASH=$PIECE($GET(^PSDRUG(PSADRG,2)),"^",4)
+1 SET PSAONDC=$PIECE(PSAODASH,"-")_$PIECE(PSAODASH,"-",2)_$PIECE(PSAODASH,"-",3)
+2 ;(PSA*3*21) NDC & PRICING UPDATES (DAVE BLOCKER 10NOV99)
+3 SET PSADUOU=$SELECT($GET(PSADUOU)'>0:1,1:PSADUOU)
+4 SET PSADUREC=(PSAQTY*PSADUOU)
+5 SET DIE="^PSDRUG("
SET DA=PSADRG
SET DR="50////^S X="_(PSADUREC+$GET(^PSDRUG(PSADRG,660.1)))
+6 FOR
LOCK +^PSDRUG(DA,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+7 DO ^DIE
LOCK -^PSDRUG(DA,0)
KILL DIE,DA,DR
+8 ;This section replaces most of the routine
+9 ;PSAOU = order unit from invoice
+10 ;PSAPOU & PSANPOU = Price of Order Unit from invoice
+11 ;PSADUOU=Dispense Units per OU form invoice data
+12 ;PSANPDU= Price of Dispense Units per Order Unit
+13 ;
+14 ;Drug file Information
+15 KILL DRUG
+16 SET PSANODE=$GET(^PSDRUG(PSADRG,660))
+17 FOR X=2,3,5,6
SET DRUG(X)=$PIECE($GET(PSANODE),"^",X)
+18 ;
+19 ;Price of Order Unit divide by Disp. Units per Order Unit
SET PSANPDU=$JUSTIFY(($GET(PSAPOU)/$GET(PSADUOU)),0,4)
+20 ;PSA*3*42 |> (let changes happen and file, put changes into mail message)
+21 ;*42;*56;*76
SET DIE="^PSDRUG("
SET (DA,OLDDA)=PSADRG
SET DR="12////^S X=PSAOU;15////^S X=PSADUOU;16///^S X=PSANPDU;13////^S X=PSAPOU"
+22 FOR
LOCK +^PSDRUG(DA,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+23 DO ^DIE
KILL DIE,DA,DR
+24 ; <| PSA*42
PTCH21 ;PSA*3*21 (Vendor's VSN changing to 8 digits, check also)
+1 ;If NDC or VSN changes should it create to synonym entry ?
+2 IF $GET(^PSDRUG(PSADRG,1,PSASUB,0))=""
GOTO NDC
+3 IF $GET(^PSDRUG(PSADRG,1,PSASUB,0))
SET PSAEDTT=0
SET DATA=^PSDRUG(PSADRG,1,PSASUB,0)
Begin DoDot:1
+4 ;VSN
IF PSAVSN'=$PIECE(DATA,"^",4)
SET PSAEDTT=1
+5 ;Price per order unit
IF PSAPOU'=$PIECE(DATA,"^",6)
SET PSAEDTT=1
+6 ;Dispense Units per Order Unit
IF PSADUOU'=$PIECE(DATA,"^",7)
SET PSAEDTT=1
+7 ;New Price per dispense unit
IF PSANPDU'=$PIECE(DATA,"^",8)
SET PSAEDTT=1
+8 IF $GET(PSAEDTT)>0
Begin DoDot:2
+9 SET DA=PSASUB
SET DA(1)=PSADRG
SET DIE="^PSDRUG("_DA(1)_",1,"
+10 SET DR="2////^S X=PSADASH"_$SELECT(PSACS:";1////C",1:";1////D")_";400////^S X=PSAVSN;401////^S X=PSAOU"_$SELECT(+PSAPOU:";402////^S X=PSAPOU",1:"")_";403////^S X=PSADUOU"_";404///^S X=PSANPDU"_";405///^S X=PSAVEND"
+11 DO ^DIE
KILL DIE,DR,DA
End DoDot:2
End DoDot:1
NDC ;NDC UPDATE
+1 ;*42
IF PSANDC'=""
IF PSANDC'=PSAONDC
Begin DoDot:1
+2 SET DIE="^PSDRUG("
SET DA=PSADRG
SET DR="31////^S X=PSADASH"
+3 FOR
LOCK +^PSDRUG(DA,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+4 DO ^DIE
LOCK -^PSDRUG(DA,0)
KILL DIE,DA,DR
End DoDot:1
SYNONYM ;Adds/edits the SYNONYM multiple in DRUG file >>*66 RJS
+1 if PSANDC=""
GOTO END
+2 ;; << *66 RJS
SET DA(1)=PSADRG
+3 ;
+4 ;Price of Order Unit divide by Disp. Units per Order Unit ;*76
SET PSANPDU=$JUSTIFY(($GET(PSAPOU)/$GET(PSADUOU)),0,4)
+5 if '$DATA(^PSDRUG(PSADRG,1,0))
SET DIC("P")="50.1A"
+6 ; *56 Search for earliest best match of synonyms, start at bottom go up
+7 ; if VSN use it, if several VSNs use the first, IF VSN match NDCs must match also.
+8 ; if no VSN, make a new synonym
+9 ; no "B" synonym index exists
T0 NEW PSYNDA,PSYN0,PSTNDC,PSTVSN,PSMNDC,PSMBTH
SET (PSMNDC,PSMBTH)=0
+1 SET PSYNDA=""
FOR
SET PSYNDA=$ORDER(^PSDRUG(PSADRG,1,PSYNDA),-1)
if PSYNDA'>0
QUIT
Begin DoDot:1
+2 ;zero node, test values of NDC VSN
SET PSYN0=^PSDRUG(PSADRG,1,PSYNDA,0)
SET PSTNDC=$PIECE(PSYN0,U)
SET PSTVSN=$PIECE(PSYN0,U,4)
+3 IF PSTNDC'=PSANDC
QUIT
+4 ;both VSN & NDC matches
IF PSTVSN=PSAVSN
SET PSMBTH=PSYNDA
QUIT
End DoDot:1
T1 ;PSAMBTH Match both vsn,ndc
SET PSASUB=$SELECT(PSMBTH:PSMBTH,1:0)
+1 ;end *56
+2 IF 'PSASUB!(PSASUB&('$DATA(^PSDRUG(PSADRG,1,PSASUB,0))))
Begin DoDot:1
+3 SET DIC="^PSDRUG("_DA(1)_",1,"
SET DIC(0)="Z"
SET X=PSANDC
SET DLAYGO=50
+4 FOR
LOCK +^PSDRUG(PSADRG,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+5 DO FILE^DICN
LOCK -^PSDRUG(PSADRG,0)
KILL DIC,DLAYGO
SET PSASUB=+Y
+6 KILL DIC,DA,DR,DIE
End DoDot:1
+7 IF PSASUB
IF $DATA(^PSDRUG(PSADRG,1,PSASUB,0))
SET DA=PSASUB
+8 SET DA(1)=PSADRG
SET DIE="^PSDRUG("_DA(1)_",1,"
+9 SET DR="2////^S X=PSADASH"_$SELECT($GET(PSACS)>0:";1////C",1:";1////D")_";400////^S X=PSAVSN;401////^S X=PSAOU"_$SELECT(+PSAPOU:";402////^S X=PSAPOU",1:"")_";403////^S X=PSADUOU"_";404///^S X=PSANPDU;405///^S X=PSAVEND"
+10 FOR
LOCK +^PSDRUG(PSADRG,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+11 DO ^DIE
LOCK -^PSDRUG(PSADRG,0)
+12 KILL DIE,DR,X1,X2,DATA
END ; FINAL CLEANUP << *66 RJS
+1 ;; >> *66 RJS
LOCK -^PSDRUG(OLDDA,0)
KILL OLDDA
+2 QUIT
