PSAPROC7 ;BIR/JMB-Process Uploaded Prime Vendor Invoice Data - CONT'D ;9/6/97
;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,12,24,27,21,42**; 10/24/97
;This routine takes the data in XTMP and moves it to DA ORDERS file.
;It deletes the data in XTMP after it is copies.
;
;References to ^PSDRUG( are covered by IA #2095
INVOICE ;PSA*3*21 (3JAN01) - FILE INVOICE IMMEDIATELY
;
S PSAIN=$G(^XTMP("PSAPV",PSACTRL,"IN")) Q:PSAIN=""
Q:$P(PSAIN,"^",8)'="P"
S PSAORD=$P(PSAIN,"^",4),PSAIEN=+$O(^PSD(58.811,"B",PSAORD,0)),PSACRED=0
I 'PSAIEN D
.F L +^PSD(58.811,0):0 I Q
.;(PSA*3*24 - Dave B. Jun 2 00 - Improper DIC call)
.S DIC="^PSD(58.811,",DIC(0)="L",X=PSAORD D FILE^DICN K DIC L -^PSD(58.811,0) S PSAIEN=+Y
F L +^PSD(58.811,PSAIEN,0):10 I Q
S:'$D(^PSD(58.811,PSAIEN,1,0)) DIC("P")=$P(^DD(58.811,2,0),"^",2)
S DA(1)=PSAIEN,DIC="^PSD(58.811,"_DA(1)_",1,",DIC(0)="L",X=$P(PSAIN,"^",2),DLAYGO=58.811 D ^DIC K DA,DLAYGO S PSAIEN1=+Y
S DA(1)=PSAIEN,DA=PSAIEN1,DIE=DIC K DIC
S PSALOCDR=$P($G(PSAIN),"^",7)
S PSADELDR=$P($G(PSAIN),"^",6)
S PSACSDR=$S($P(PSAIN,"^",10)="ALL CS":"A",$P(PSAIN,"^",9)="CS":"S",1:"N")
S PSARECD=$P($G(PSAIN),"^",11)
S PSAMV=$S(+$P(PSAIN,"^",12):$P(PSAIN,"^",12),1:"")
S PSASUP=$S($P(PSAIN,"^",13)="SUP":1,1:"")
;DAVE B ( PSA*3*12) Invalid Concatenation of zero node
S ^PSD(58.811,DA(1),1,DA,0)=$P(^(0),"^")_"^"_$P(PSAIN,"^",1)_"^P^"_$P(PSAIN,"^",3)_"^"_$G(PSALOCDR)_"^"_$G(PSADELDR)_"^"_$G(PSARECD)_"^"_$G(PSACSDR)_"^^"_DUZ_"^^"_$G(PSAMV)_"^"_$G(PSASUP)
S DIK=DIE D IX^DIK
K ^TMP($J,"PSADIF"),PSADIFLC ;*42 pre verify storage for OU, DUOU, Cost, NDC changes
S PSALINE=0 F S PSALINE=$O(^XTMP("PSAPV",PSACTRL,"IT",PSALINE)) Q:PSALINE="" D LINE
D SCANDIF,MM ;*42 look for differences to drug file SEND EMAIL
I PSACRED K DA S DA(1)=PSAIEN,DA=PSAIEN1,DIE="^PSD(58.811,"_DA(1)_",1,",DR="10///^S X=1" D ^DIE K DIE
S $P(^PSD(58.811,PSAIEN,0),"^",2)=$P($G(^XTMP("PSAPV",PSACTRL,"DS")),"^")
L -^PSD(58.811,PSAIEN,0)
K ^XTMP("PSAPV",PSACTRL)
Q
;
LINE ;Files line items.
S PSADATA=^XTMP("PSAPV",PSACTRL,"IT",PSALINE) S:'$D(^PSD(58.811,PSAIEN,1,PSAIEN1,1,0)) DIC("P")=$P(^DD(58.8112,5,0),"^",2)
;PSA*3*31 Dave B - Check for invoice already in file
S DA(2)=PSAIEN,DA(1)=PSAIEN1,(DA,X)=PSALINE,DIC="^PSD(58.811,"_DA(2)_",1,"_DA(1)_",1,",DIC(0)="L",DLAYGO=58.811 D ^DIC S PSAIEN2=+Y K DA,DIC,DLAYGO
;
;DAVEB PSA*3*3 (5may98)
S PSADRG=$P($G(PSADATA),"^",6)
S PSASYN=$P($G(PSADATA),"^",7)
K PSAUNIT
I $G(PSASYN)'="",$G(PSADRG)'="" S PSAUNIT=+$P($G(^PSDRUG(PSADRG,1,PSASYN,0)),"^",5)
;
;DAVE B (PSA*3*12) Assignment of order unit didn't take into
;account the adjusted order unit.
S PSAUNIT=$S($D(PSAUNIT):PSAUNIT,$P(PSADATA,"^",12)'="":$P(PSADATA,"^",12),+$P($P(PSADATA,"^",2),"~",2):+$P($P(PSADATA,"^",2),"~",2),1:0)
S PSACS=$S($P(PSADATA,"^",19)="CS":1,1:0),PSANDC=$P($P(PSADATA,"^",4),"~"),PSAVSN=$P($P(PSADATA,"^",5),"~"),PSAUPC=$P($P(PSADATA,"^",26),"~")
I PSANDC="",$P($P(PSADATA,"^",26),"~")'="" S PSANDC="S"_$P($P(PSADATA,"^",26),"~")
S DA(2)=PSAIEN,DA(1)=PSAIEN1,DA=$S($D(PSAIEN2):PSAIEN2,1:PSALINE),DIE="^PSD(58.811,"_DA(2)_",1,"_DA(1)_",1,"
;DaveB (4may98) hard code filing data
S $P(^PSD(58.811,DA(2),1,DA(1),1,DA,0),"^",3)=+PSADATA
S $P(^PSD(58.811,DA(2),1,DA(1),1,DA,0),"^",11)=PSANDC
S $P(^PSD(58.811,DA(2),1,DA(1),1,DA,0),"^",12)=PSAVSN
S $P(^PSD(58.811,DA(2),1,DA(1),1,DA,0),"^",13)=PSAUPC
S $P(^PSD(58.811,DA(2),1,DA(1),1,DA,0),"^",10)=PSACS
S $P(^PSD(58.811,DA(2),1,DA(1),1,DA,0),"^",2)=PSADRG
S $P(^PSD(58.811,DA(2),1,DA(1),1,DA,0),"^",4)=PSAUNIT
S $P(^PSD(58.811,DA(2),1,DA(1),1,DA,0),"^",5)=$P(PSADATA,"^",3)
S $P(^PSD(58.811,DA(2),1,DA(1),1,DA,0),"^",6)=DT
S $P(^PSD(58.811,DA(2),1,DA(1),1,DA,0),"^",7)=DUZ
S DIK=DIE D IX^DIK
;End PSA*3*7
;
I +$P(PSADATA,"^",15)!($D(^XTMP("PSAPV",PSACTRL,"IT",PSALINE,"SUP"))) D ADJDRUG
I $P(PSADATA,"^",8)'="" D QTY
I +$P(PSADATA,"^",12) D OU
I +$P(PSADATA,"^",23) D PRICE
;Adds the reorder level and/or dispense units per order unit
I +$P(PSADATA,"^",7)!(+$P(PSADATA,"^",20))!(+$P(PSADATA,"^",21))!(+$P(PSADATA,"^",27)) D
.S ^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSAIEN2,2)=$P(PSADATA,"^",20)_"^"_$P(PSADATA,"^",21)_"^"_$S(+$P(PSADATA,"^",7):+$P(PSADATA,"^",7),1:0)_"^"_+$P(PSADATA,"^",27)
K ^XTMP("PSAPV",PSACTRL,"IT",PSALINE)
Q
ADJDRUG ;Records adjusted drug received
S PSAFLD="D"
I +$P(PSADATA,"^",15) S PSADJ=+$P(PSADATA,"^",15),PSADUZ=+$P(PSADATA,"^",16),PSADT=+$P(PSADATA,"^",17),PSAREA="" D RECORD Q
I $D(^XTMP("PSAPV",PSACTRL,"IT",PSALINE,"SUP")) S PSASNODE=^XTMP("PSAPV",PSACTRL,"IT",PSALINE,"SUP"),PSADJ=$P(PSASNODE,"^",3),PSADUZ=+$P(PSASNODE,"^"),PSADT=+$P(PSASNODE,"^",2),PSAREA="" D RECORD
Q
OU ;Records adjusted order unit
S PSAFLD="O",PSADJ=+$P(PSADATA,"^",12),PSADUZ=+$P(PSADATA,"^",13),PSADT=+$P(PSADATA,"^",14),PSAREA=""
D RECORD
Q
PRICE ;Records adjusted price per order unit
S PSAFLD="P",PSADJ=+$P(PSADATA,"^",23),PSADUZ=+$P(PSADATA,"^",24),PSADT=+$P(PSADATA,"^",25),PSAREA=""
S:PSADJ'=+$P(PSADATA,"^",3) PSACRED=1
D RECORD
Q
QTY ;Records adjusted quantity received.
S PSAFLD="Q",PSADJ=+$P(PSADATA,"^",8),PSADUZ=+$P(PSADATA,"^",9),PSADT=+$P(PSADATA,"^",10),PSAREA=$P(PSADATA,"^",11)
S:PSADJ'=+$P(PSADATA,"^") PSACRED=1
D RECORD
Q
RECORD ;Adds adjusted data to DA ORDERS file
K DA S DA(3)=PSAIEN,DA(2)=PSAIEN1,DA(1)=PSAIEN2,X=PSAFLD
S:'$D(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSAIEN2,1,0)) DIC("P")=$P(^DD(58.81125,9,0),"^",2)
;PSA*3*27 (DAVE B) removed killing of DA variable on next line
S DIC="^PSD(58.811,"_DA(3)_",1,"_DA(2)_",1,"_DA(1)_",1,",DIC(0)="L",DLAYGO=58.811 D ^DIC S PSAIEN3=+Y K DLAYGO
;
;PSA*3*3
;DAVEB Hard code filing
S DIE=DIC,DA=PSAIEN3
S $P(^PSD(58.811,DA(3),1,DA(2),1,DA(1),1,DA,0),"^",2)=PSADJ
S $P(^PSD(58.811,DA(3),1,DA(2),1,DA(1),1,DA,0),"^",3)=$G(PSAREA)
S $P(^PSD(58.811,DA(3),1,DA(2),1,DA(1),1,DA,0),"^",4)=DT
S $P(^PSD(58.811,DA(3),1,DA(2),1,DA(1),1,DA,0),"^",5)=DUZ
;
;S DIE=DIC,DA=PSAIEN3,DR="1///"_PSADJ_$S(PSAREA'="":";2////^S X=PSAREA",1:"")_";3///^S X="_PSADT_";4///^S X="_PSADUZ K DIC D ^DIE
S DIK=DIE,DA=PSAIEN3 D IX1^DIK K DA,DIE,DIK,PSAFLD
Q
;*42 CHANGES
SCANDIF ; 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
Q
MM ;
I $D(^TMP($J,"PSADIF")) D MESSAGE
Q
CHECK ;Check line item for differences to drug file *42
N ITM,ITMI,DRG,DRIEN,DIF,ZZ,XX,XXX,PCNT,PDIF,T,IENS
; use new API call to retrieve item fields see PSAUTL6
D ITEM^PSAUTL6(PSAIEN,PSAIEN1,PSALINE,.ITM)
D ITEM^PSAUTL6(PSAIEN,PSAIEN1,PSALINE,.ITMI,"I")
I ITM(2)'>0 Q ;zero quantity will not be filed
S ITM("OU")=ITM(3),ITM("DUOU")=ITM(10),ITM("NDC")=ITM(13),ITM("PPOU")=ITM(4),ITM("PPDU")=$J(ITM("PPOU")/ITM("DUOU"),1,4)
S DRIEN=+ITMI(1)
S DRG("OU")=$$GET1^DIQ(50,DRIEN,12),DRG("DUOU")=$$GET1^DIQ(50,DRIEN,15),DRG("NDC")=$$GET1^DIQ(50,DRIEN,31),DRG("PPDU")=$$GET1^DIQ(50,DRIEN,16)
K DIF
F XX="OU","DUOU","NDC" I ITM(XX)'=DRG(XX) S DIF(XX)=""
I ITM("PPDU")'=DRG("PPDU") S PCNT=.05*DRG("PPDU"),PDIF=DRG("PPDU")-ITM("PPDU") S:PDIF<0 PDIF=-1*PDIF S:PDIF>PCNT DIF("PPDU")=""
I $D(DIF) D
. F ZZ=" ",$J(ITM(.01),3)_" "_ITM(1) D SET
. S XXX="" F S XXX=$O(DIF(XXX)) Q:XXX="" D
.. S ZZ=" ",T=XXX,ZZ=$$SETSTR^VALM1(T,ZZ,4,$L(T))
.. S T="Old: "_DRG(XXX),ZZ=$$SETSTR^VALM1(T,ZZ,13,$L(T))
.. S T="New: "_ITM(XXX),ZZ=$$SETSTR^VALM1(T,ZZ,36,$L(T))
.. D SET
Q
SET ;set differences into ^TMP
S:'$G(PSADIFLC) PSADIFLC=3
S ^TMP($J,"PSADIF",PSADIFLC,0)=ZZ,PSADIFLC=PSADIFLC+1
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="PRE Verify "_PSAORD_" : "_PSAINV_" Variance Report"
S ^TMP($J,"PSADIF",1,0)=XMSUB,^TMP($J,"PSADIF",2,0)=" "
W !,XMSUB,!
W !,"Noted differences between the invoice line items and the drug file have",!,"been found. A mail message is being sent to G.PSA NDC UPDATES."
W !!," Please check the message for accuracy.",!
K DIR S DIR(0)="E",DIR("A")="<cr> - continue" D ^DIR
K DIR
S XMTEXT="^TMP($J,""PSADIF"",",XMY("G.PSA NDC UPDATES")=""
D ^XMD
K PSADIFLC,^TMP($J,"PSADIF")
Q
PSAPROC7 ;BIR/JMB-Process Uploaded Prime Vendor Invoice Data - CONT'D ;9/6/97
+1 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,12,24,27,21,42**; 10/24/97
+2 ;This routine takes the data in XTMP and moves it to DA ORDERS file.
+3 ;It deletes the data in XTMP after it is copies.
+4 ;
+5 ;References to ^PSDRUG( are covered by IA #2095
INVOICE ;PSA*3*21 (3JAN01) - FILE INVOICE IMMEDIATELY
+1 ;
+2 SET PSAIN=$GET(^XTMP("PSAPV",PSACTRL,"IN"))
IF PSAIN=""
QUIT
+3 IF $PIECE(PSAIN,"^",8)'="P"
QUIT
+4 SET PSAORD=$PIECE(PSAIN,"^",4)
SET PSAIEN=+$ORDER(^PSD(58.811,"B",PSAORD,0))
SET PSACRED=0
+5 IF 'PSAIEN
Begin DoDot:1
+6 FOR
LOCK +^PSD(58.811,0):0
IF $TEST
QUIT
+7 ;(PSA*3*24 - Dave B. Jun 2 00 - Improper DIC call)
+8 SET DIC="^PSD(58.811,"
SET DIC(0)="L"
SET X=PSAORD
DO FILE^DICN
KILL DIC
LOCK -^PSD(58.811,0)
SET PSAIEN=+Y
End DoDot:1
+9 FOR
LOCK +^PSD(58.811,PSAIEN,0):10
IF $TEST
QUIT
+10 IF '$DATA(^PSD(58.811,PSAIEN,1,0))
SET DIC("P")=$PIECE(^DD(58.811,2,0),"^",2)
+11 SET DA(1)=PSAIEN
SET DIC="^PSD(58.811,"_DA(1)_",1,"
SET DIC(0)="L"
SET X=$PIECE(PSAIN,"^",2)
SET DLAYGO=58.811
DO ^DIC
KILL DA,DLAYGO
SET PSAIEN1=+Y
+12 SET DA(1)=PSAIEN
SET DA=PSAIEN1
SET DIE=DIC
KILL DIC
+13 SET PSALOCDR=$PIECE($GET(PSAIN),"^",7)
+14 SET PSADELDR=$PIECE($GET(PSAIN),"^",6)
+15 SET PSACSDR=$SELECT($PIECE(PSAIN,"^",10)="ALL CS":"A",$PIECE(PSAIN,"^",9)="CS":"S",1:"N")
+16 SET PSARECD=$PIECE($GET(PSAIN),"^",11)
+17 SET PSAMV=$SELECT(+$PIECE(PSAIN,"^",12):$PIECE(PSAIN,"^",12),1:"")
+18 SET PSASUP=$SELECT($PIECE(PSAIN,"^",13)="SUP":1,1:"")
+19 ;DAVE B ( PSA*3*12) Invalid Concatenation of zero node
+20 SET ^PSD(58.811,DA(1),1,DA,0)=$PIECE(^(0),"^")_"^"_$PIECE(PSAIN,"^",1)_"^P^"_$PIECE(PSAIN,"^",3)_"^"_$GET(PSALOCDR)_"^"_$GET(PSADELDR)_"^"_$GET(PSARECD)_"^"_$GET(PSACSDR)_"^^"_DUZ_"^^"_$GET(PSAMV)_"^"_$GET(PSASUP)
+21 SET DIK=DIE
DO IX^DIK
+22 ;*42 pre verify storage for OU, DUOU, Cost, NDC changes
KILL ^TMP($JOB,"PSADIF"),PSADIFLC
+23 SET PSALINE=0
FOR
SET PSALINE=$ORDER(^XTMP("PSAPV",PSACTRL,"IT",PSALINE))
IF PSALINE=""
QUIT
DO LINE
+24 ;*42 look for differences to drug file SEND EMAIL
DO SCANDIF
DO MM
+25 IF PSACRED
KILL DA
SET DA(1)=PSAIEN
SET DA=PSAIEN1
SET DIE="^PSD(58.811,"_DA(1)_",1,"
SET DR="10///^S X=1"
DO ^DIE
KILL DIE
+26 SET $PIECE(^PSD(58.811,PSAIEN,0),"^",2)=$PIECE($GET(^XTMP("PSAPV",PSACTRL,"DS")),"^")
+27 LOCK -^PSD(58.811,PSAIEN,0)
+28 KILL ^XTMP("PSAPV",PSACTRL)
+29 QUIT
+30 ;
LINE ;Files line items.
+1 SET PSADATA=^XTMP("PSAPV",PSACTRL,"IT",PSALINE)
IF '$DATA(^PSD(58.811,PSAIEN,1,PSAIEN1,1,0))
SET DIC("P")=$PIECE(^DD(58.8112,5,0),"^",2)
+2 ;PSA*3*31 Dave B - Check for invoice already in file
+3 SET DA(2)=PSAIEN
SET DA(1)=PSAIEN1
SET (DA,X)=PSALINE
SET DIC="^PSD(58.811,"_DA(2)_",1,"_DA(1)_",1,"
SET DIC(0)="L"
SET DLAYGO=58.811
DO ^DIC
SET PSAIEN2=+Y
KILL DA,DIC,DLAYGO
+4 ;
+5 ;DAVEB PSA*3*3 (5may98)
+6 SET PSADRG=$PIECE($GET(PSADATA),"^",6)
+7 SET PSASYN=$PIECE($GET(PSADATA),"^",7)
+8 KILL PSAUNIT
+9 IF $GET(PSASYN)'=""
IF $GET(PSADRG)'=""
SET PSAUNIT=+$PIECE($GET(^PSDRUG(PSADRG,1,PSASYN,0)),"^",5)
+10 ;
+11 ;DAVE B (PSA*3*12) Assignment of order unit didn't take into
+12 ;account the adjusted order unit.
+13 SET PSAUNIT=$SELECT($DATA(PSAUNIT):PSAUNIT,$PIECE(PSADATA,"^",12)'="":$PIECE(PSADATA,"^",12),+$PIECE($PIECE(PSADATA,"^",2),"~",2):+$PIECE($PIECE(PSADATA,"^",2),"~",2),1:0)
+14 SET PSACS=$SELECT($PIECE(PSADATA,"^",19)="CS":1,1:0)
SET PSANDC=$PIECE($PIECE(PSADATA,"^",4),"~")
SET PSAVSN=$PIECE($PIECE(PSADATA,"^",5),"~")
SET PSAUPC=$PIECE($PIECE(PSADATA,"^",26),"~")
+15 IF PSANDC=""
IF $PIECE($PIECE(PSADATA,"^",26),"~")'=""
SET PSANDC="S"_$PIECE($PIECE(PSADATA,"^",26),"~")
+16 SET DA(2)=PSAIEN
SET DA(1)=PSAIEN1
SET DA=$SELECT($DATA(PSAIEN2):PSAIEN2,1:PSALINE)
SET DIE="^PSD(58.811,"_DA(2)_",1,"_DA(1)_",1,"
+17 ;DaveB (4may98) hard code filing data
+18 SET $PIECE(^PSD(58.811,DA(2),1,DA(1),1,DA,0),"^",3)=+PSADATA
+19 SET $PIECE(^PSD(58.811,DA(2),1,DA(1),1,DA,0),"^",11)=PSANDC
+20 SET $PIECE(^PSD(58.811,DA(2),1,DA(1),1,DA,0),"^",12)=PSAVSN
+21 SET $PIECE(^PSD(58.811,DA(2),1,DA(1),1,DA,0),"^",13)=PSAUPC
+22 SET $PIECE(^PSD(58.811,DA(2),1,DA(1),1,DA,0),"^",10)=PSACS
+23 SET $PIECE(^PSD(58.811,DA(2),1,DA(1),1,DA,0),"^",2)=PSADRG
+24 SET $PIECE(^PSD(58.811,DA(2),1,DA(1),1,DA,0),"^",4)=PSAUNIT
+25 SET $PIECE(^PSD(58.811,DA(2),1,DA(1),1,DA,0),"^",5)=$PIECE(PSADATA,"^",3)
+26 SET $PIECE(^PSD(58.811,DA(2),1,DA(1),1,DA,0),"^",6)=DT
+27 SET $PIECE(^PSD(58.811,DA(2),1,DA(1),1,DA,0),"^",7)=DUZ
+28 SET DIK=DIE
DO IX^DIK
+29 ;End PSA*3*7
+30 ;
+31 IF +$PIECE(PSADATA,"^",15)!($DATA(^XTMP("PSAPV",PSACTRL,"IT",PSALINE,"SUP")))
DO ADJDRUG
+32 IF $PIECE(PSADATA,"^",8)'=""
DO QTY
+33 IF +$PIECE(PSADATA,"^",12)
DO OU
+34 IF +$PIECE(PSADATA,"^",23)
DO PRICE
+35 ;Adds the reorder level and/or dispense units per order unit
+36 IF +$PIECE(PSADATA,"^",7)!(+$PIECE(PSADATA,"^",20))!(+$PIECE(PSADATA,"^",21))!(+$PIECE(PSADATA,"^",27))
Begin DoDot:1
+37 SET ^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSAIEN2,2)=$PIECE(PSADATA,"^",20)_"^"_$PIECE(PSADATA,"^",21)_"^"_$SELECT(+$PIECE(PSADATA,"^",7):+$PIECE(PSADATA,"^",7),1:0)_"^"_+$PIECE(PSADATA,"^",27)
End DoDot:1
+38 KILL ^XTMP("PSAPV",PSACTRL,"IT",PSALINE)
+39 QUIT
ADJDRUG ;Records adjusted drug received
+1 SET PSAFLD="D"
+2 IF +$PIECE(PSADATA,"^",15)
SET PSADJ=+$PIECE(PSADATA,"^",15)
SET PSADUZ=+$PIECE(PSADATA,"^",16)
SET PSADT=+$PIECE(PSADATA,"^",17)
SET PSAREA=""
DO RECORD
QUIT
+3 IF $DATA(^XTMP("PSAPV",PSACTRL,"IT",PSALINE,"SUP"))
SET PSASNODE=^XTMP("PSAPV",PSACTRL,"IT",PSALINE,"SUP")
SET PSADJ=$PIECE(PSASNODE,"^",3)
SET PSADUZ=+$PIECE(PSASNODE,"^")
SET PSADT=+$PIECE(PSASNODE,"^",2)
SET PSAREA=""
DO RECORD
+4 QUIT
OU ;Records adjusted order unit
+1 SET PSAFLD="O"
SET PSADJ=+$PIECE(PSADATA,"^",12)
SET PSADUZ=+$PIECE(PSADATA,"^",13)
SET PSADT=+$PIECE(PSADATA,"^",14)
SET PSAREA=""
+2 DO RECORD
+3 QUIT
PRICE ;Records adjusted price per order unit
+1 SET PSAFLD="P"
SET PSADJ=+$PIECE(PSADATA,"^",23)
SET PSADUZ=+$PIECE(PSADATA,"^",24)
SET PSADT=+$PIECE(PSADATA,"^",25)
SET PSAREA=""
+2 IF PSADJ'=+$PIECE(PSADATA,"^",3)
SET PSACRED=1
+3 DO RECORD
+4 QUIT
QTY ;Records adjusted quantity received.
+1 SET PSAFLD="Q"
SET PSADJ=+$PIECE(PSADATA,"^",8)
SET PSADUZ=+$PIECE(PSADATA,"^",9)
SET PSADT=+$PIECE(PSADATA,"^",10)
SET PSAREA=$PIECE(PSADATA,"^",11)
+2 IF PSADJ'=+$PIECE(PSADATA,"^")
SET PSACRED=1
+3 DO RECORD
+4 QUIT
RECORD ;Adds adjusted data to DA ORDERS file
+1 KILL DA
SET DA(3)=PSAIEN
SET DA(2)=PSAIEN1
SET DA(1)=PSAIEN2
SET X=PSAFLD
+2 IF '$DATA(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSAIEN2,1,0))
SET DIC("P")=$PIECE(^DD(58.81125,9,0),"^",2)
+3 ;PSA*3*27 (DAVE B) removed killing of DA variable on next line
+4 SET DIC="^PSD(58.811,"_DA(3)_",1,"_DA(2)_",1,"_DA(1)_",1,"
SET DIC(0)="L"
SET DLAYGO=58.811
DO ^DIC
SET PSAIEN3=+Y
KILL DLAYGO
+5 ;
+6 ;PSA*3*3
+7 ;DAVEB Hard code filing
+8 SET DIE=DIC
SET DA=PSAIEN3
+9 SET $PIECE(^PSD(58.811,DA(3),1,DA(2),1,DA(1),1,DA,0),"^",2)=PSADJ
+10 SET $PIECE(^PSD(58.811,DA(3),1,DA(2),1,DA(1),1,DA,0),"^",3)=$GET(PSAREA)
+11 SET $PIECE(^PSD(58.811,DA(3),1,DA(2),1,DA(1),1,DA,0),"^",4)=DT
+12 SET $PIECE(^PSD(58.811,DA(3),1,DA(2),1,DA(1),1,DA,0),"^",5)=DUZ
+13 ;
+14 ;S DIE=DIC,DA=PSAIEN3,DR="1///"_PSADJ_$S(PSAREA'="":";2////^S X=PSAREA",1:"")_";3///^S X="_PSADT_";4///^S X="_PSADUZ K DIC D ^DIE
+15 SET DIK=DIE
SET DA=PSAIEN3
DO IX1^DIK
KILL DA,DIE,DIK,PSAFLD
+16 QUIT
+17 ;*42 CHANGES
SCANDIF ; inspect invoice for noted differences in OU,DUOU,PPDU,NDC
+1 ;NEEDS PSAIEN, PSAIEN1
+2 KILL ^TMP($JOB,"PSADIF"),PSADIFLC
+3 SET PSALINE=0
FOR
SET PSALINE=$ORDER(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE))
IF PSALINE'>0
QUIT
DO CHECK
+4 QUIT
MM ;
+1 IF $DATA(^TMP($JOB,"PSADIF"))
DO MESSAGE
+2 QUIT
CHECK ;Check line item for differences to drug file *42
+1 NEW ITM,ITMI,DRG,DRIEN,DIF,ZZ,XX,XXX,PCNT,PDIF,T,IENS
+2 ; use new API call to retrieve item fields see PSAUTL6
+3 DO ITEM^PSAUTL6(PSAIEN,PSAIEN1,PSALINE,.ITM)
+4 DO ITEM^PSAUTL6(PSAIEN,PSAIEN1,PSALINE,.ITMI,"I")
+5 ;zero quantity will not be filed
IF ITM(2)'>0
QUIT
+6 SET ITM("OU")=ITM(3)
SET ITM("DUOU")=ITM(10)
SET ITM("NDC")=ITM(13)
SET ITM("PPOU")=ITM(4)
SET ITM("PPDU")=$JUSTIFY(ITM("PPOU")/ITM("DUOU"),1,4)
+7 SET DRIEN=+ITMI(1)
+8 SET DRG("OU")=$$GET1^DIQ(50,DRIEN,12)
SET DRG("DUOU")=$$GET1^DIQ(50,DRIEN,15)
SET DRG("NDC")=$$GET1^DIQ(50,DRIEN,31)
SET DRG("PPDU")=$$GET1^DIQ(50,DRIEN,16)
+9 KILL DIF
+10 FOR XX="OU","DUOU","NDC"
IF ITM(XX)'=DRG(XX)
SET DIF(XX)=""
+11 IF ITM("PPDU")'=DRG("PPDU")
SET PCNT=.05*DRG("PPDU")
SET PDIF=DRG("PPDU")-ITM("PPDU")
IF PDIF<0
SET PDIF=-1*PDIF
IF PDIF>PCNT
SET DIF("PPDU")=""
+12 IF $DATA(DIF)
Begin DoDot:1
+13 FOR ZZ=" ",$JUSTIFY(ITM(.01),3)_" "_ITM(1)
DO SET
+14 SET XXX=""
FOR
SET XXX=$ORDER(DIF(XXX))
IF XXX=""
QUIT
Begin DoDot:2
+15 SET ZZ=" "
SET T=XXX
SET ZZ=$$SETSTR^VALM1(T,ZZ,4,$LENGTH(T))
+16 SET T="Old: "_DRG(XXX)
SET ZZ=$$SETSTR^VALM1(T,ZZ,13,$LENGTH(T))
+17 SET T="New: "_ITM(XXX)
SET ZZ=$$SETSTR^VALM1(T,ZZ,36,$LENGTH(T))
+18 DO SET
End DoDot:2
End DoDot:1
+19 QUIT
SET ;set differences into ^TMP
+1 IF '$GET(PSADIFLC)
SET PSADIFLC=3
+2 SET ^TMP($JOB,"PSADIF",PSADIFLC,0)=ZZ
SET PSADIFLC=PSADIFLC+1
+3 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 SET XMSUB="PRE Verify "_PSAORD_" : "_PSAINV_" Variance Report"
+5 SET ^TMP($JOB,"PSADIF",1,0)=XMSUB
SET ^TMP($JOB,"PSADIF",2,0)=" "
+6 WRITE !,XMSUB,!
+7 WRITE !,"Noted differences between the invoice line items and the drug file have",!,"been found. A mail message is being sent to G.PSA NDC UPDATES."
+8 WRITE !!," Please check the message for accuracy.",!
+9 KILL DIR
SET DIR(0)="E"
SET DIR("A")="<cr> - continue"
DO ^DIR
+10 KILL DIR
+11 SET XMTEXT="^TMP($J,""PSADIF"","
SET XMY("G.PSA NDC UPDATES")=""
+12 DO ^XMD
+13 KILL PSADIFLC,^TMP($JOB,"PSADIF")
+14 QUIT
