PSAPROC7.m

PSAPROC7 ;BIR/JMB-Process Uploaded Prime Vendor Invoice Data - CONT'D ;9/6/97

 ;;3.0;DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,12,27,21,42,61,64,67,68,71,73**; 10/24/97;Build 3

 ;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):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I  Q

 .;(PSA*3*24 - Dave B. Jun 2 00 - Improper DIC call)

 .;(PSA*3*61 - add N DO. DICN will use DO if defined, we do not want to use it since DIC is defined.

 .N DO 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($G(PSAUNIT):PSAUNIT,$P(PSADATA,"^",12)'="":$P(PSADATA,"^",12),+$P($P(PSADATA,"^",2),"~",2):+$P($P(PSADATA,"^",2),"~",2),1:0)  ;;*71

 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

 ;BGN 67

 S $P(^PSD(58.811,DA(2),1,DA(1),3,DA,0),"^",1)=$P(PSADATA,"^",28)

 S $P(^PSD(58.811,DA(2),1,DA(1),3,DA,0),"^",2)=$P(PSADATA,"^",29)

 S $P(^PSD(58.811,DA(2),1,DA(1),3,DA,0),"^",3)=$P(PSADATA,"^",30)

 S $P(^PSD(58.811,DA(2),1,DA(1),3,DA,0),"^",4)=$P(PSADATA,"^",31)

 ;END 67

 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)

 ;Bgn 67

 I $P($P(PSADATA,"^",5),"~")'="" S ^XTMP("PSAVSN",$P($P(PSADATA,"^",5),"~"))=$P(PSADATA,"^",28)_"^"_$P(PSADATA,"^",29)_"^"_$P(PSADATA,"^",30)_"^"_$P(PSADATA,"^",31)

 ;End 67

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

 I ITMI(1)'?1.N S DRIEN=ITMI(1)

 I ITMI(1)?1.N S DRIEN=+ITMI(1)

 Q:'$D(^PSDRUG(DRIEN))

 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 $D(DRG(XX)),ITM(XX)'=DRG(XX) S DIF(XX)=""

 I $G(DRG("PPDU")),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")=""

 S:ITM("OU")=""!(ITM("OU")=0) ITM("OU")="Blank",DIF("OU")=""  ;;*71

 S:DRG("OU")=""!(DRG("OU")=0) DRG("OU")="Blank",DIF("OU")=""  ;;*71

 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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PSAPROC7   9120     printed  Mar 13, 2025@20:54:49                                                                                                                                                                                                    Page 2

PSAPROC7  ;BIR/JMB-Process Uploaded Prime Vendor Invoice Data - CONT'D ;9/6/97

 +1       ;;3.0;DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,12,27,21,42,61,64,67,68,71,73**; 10/24/97;Build 3

 +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):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)

                      IF $TEST

                           QUIT 

 +7       ;(PSA*3*24 - Dave B. Jun 2 00 - Improper DIC call)

 +8       ;(PSA*3*61 - add N DO. DICN will use DO if defined, we do not want to use it since DIC is defined.

 +9                NEW DO

                   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

 +10       FOR 

               LOCK +^PSD(58.811,PSAIEN,0):10

              IF $TEST

                   QUIT 

 +11       if '$DATA(^PSD(58.811,PSAIEN,1,0))

               SET DIC("P")=$PIECE(^DD(58.811,2,0),"^",2)

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

 +13       SET DA(1)=PSAIEN

           SET DA=PSAIEN1

           SET DIE=DIC

           KILL DIC

 +14       SET PSALOCDR=$PIECE($GET(PSAIN),"^",7)

 +15       SET PSADELDR=$PIECE($GET(PSAIN),"^",6)

 +16       SET PSACSDR=$SELECT($PIECE(PSAIN,"^",10)="ALL CS":"A",$PIECE(PSAIN,"^",9)="CS":"S",1:"N")

 +17       SET PSARECD=$PIECE($GET(PSAIN),"^",11)

 +18       SET PSAMV=$SELECT(+$PIECE(PSAIN,"^",12):$PIECE(PSAIN,"^",12),1:"")

 +19       SET PSASUP=$SELECT($PIECE(PSAIN,"^",13)="SUP":1,1:"")

 +20      ;DAVE B ( PSA*3*12) Invalid Concatenation of zero node

 +21       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)

 +22       SET DIK=DIE

           DO IX^DIK

 +23      ;*42 pre verify storage for  OU, DUOU, Cost, NDC changes

           KILL ^TMP($JOB,"PSADIF"),PSADIFLC

 +24       SET PSALINE=0

           FOR 

               SET PSALINE=$ORDER(^XTMP("PSAPV",PSACTRL,"IT",PSALINE))

               if PSALINE=""

                   QUIT 

               DO LINE

 +25      ;*42 look for differences to drug file SEND EMAIL

           DO SCANDIF

           DO MM

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

 +27       SET $PIECE(^PSD(58.811,PSAIEN,0),"^",2)=$PIECE($GET(^XTMP("PSAPV",PSACTRL,"DS")),"^")

 +28       LOCK -^PSD(58.811,PSAIEN,0)

 +29       KILL ^XTMP("PSAPV",PSACTRL)

 +30       QUIT 

 +31      ;

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      ;;*71

           SET PSAUNIT=$SELECT($GET(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      ;BGN 67

 +29       SET $PIECE(^PSD(58.811,DA(2),1,DA(1),3,DA,0),"^",1)=$PIECE(PSADATA,"^",28)

 +30       SET $PIECE(^PSD(58.811,DA(2),1,DA(1),3,DA,0),"^",2)=$PIECE(PSADATA,"^",29)

 +31       SET $PIECE(^PSD(58.811,DA(2),1,DA(1),3,DA,0),"^",3)=$PIECE(PSADATA,"^",30)

 +32       SET $PIECE(^PSD(58.811,DA(2),1,DA(1),3,DA,0),"^",4)=$PIECE(PSADATA,"^",31)

 +33      ;END 67

 +34       SET DIK=DIE

           DO IX^DIK

 +35      ;End PSA*3*7

 +36      ;

 +37       IF +$PIECE(PSADATA,"^",15)!($DATA(^XTMP("PSAPV",PSACTRL,"IT",PSALINE,"SUP")))

               DO ADJDRUG

 +38       IF $PIECE(PSADATA,"^",8)'=""

               DO QTY

 +39       IF +$PIECE(PSADATA,"^",12)

               DO OU

 +40       IF +$PIECE(PSADATA,"^",23)

               DO PRICE

 +41      ;Adds the reorder level and/or dispense units per order unit

 +42       IF +$PIECE(PSADATA,"^",7)!(+$PIECE(PSADATA,"^",20))!(+$PIECE(PSADATA,"^",21))!(+$PIECE(PSADATA,"^",27))

               Begin DoDot:1

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

 +44      ;Bgn 67

 +45       IF $PIECE($PIECE(PSADATA,"^",5),"~")'=""

               SET ^XTMP("PSAVSN",$PIECE($PIECE(PSADATA,"^",5),"~"))=$PIECE(PSADATA,"^",28)_"^"_$PIECE(PSADATA,"^",29)_"^"_$PIECE(PSADATA,"^",30)_"^"_$PIECE(PSADATA,"^",31)

 +46      ;End 67

 +47       KILL ^XTMP("PSAPV",PSACTRL,"IT",PSALINE)

 +48       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       SET DIK=DIE

           SET DA=PSAIEN3

           DO IX1^DIK

           KILL DA,DIE,DIK,PSAFLD

 +15       QUIT 

 +16      ;*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        IF ITMI(1)'?1.N

               SET DRIEN=ITMI(1)

 +8        IF ITMI(1)?1.N

               SET DRIEN=+ITMI(1)

 +9        if '$DATA(^PSDRUG(DRIEN))

               QUIT 

 +10       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)

 +11       KILL DIF

 +12       FOR XX="OU","DUOU","NDC"

               IF $DATA(DRG(XX))

                   IF ITM(XX)'=DRG(XX)

                       SET DIF(XX)=""

 +13       IF $GET(DRG("PPDU"))

               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")=""

 +14      ;;*71

           if ITM("OU")=""!(ITM("OU")=0)

               SET ITM("OU")="Blank"

               SET DIF("OU")=""

 +15      ;;*71

           if DRG("OU")=""!(DRG("OU")=0)

               SET DRG("OU")="Blank"

               SET DIF("OU")=""

 +16       IF $DATA(DIF)

               Begin DoDot:1

 +17               FOR ZZ=" ",$JUSTIFY(ITM(.01),3)_"   "_ITM(1)

                       DO SET

 +18               SET XXX=""

                   FOR 

                       SET XXX=$ORDER(DIF(XXX))

                       if XXX=""

                           QUIT 

                       Begin DoDot:2

 +19                       SET ZZ="  "

                           SET T=XXX

                           SET ZZ=$$SETSTR^VALM1(T,ZZ,4,$LENGTH(T))

 +20                       SET T="Old: "_DRG(XXX)

                           SET ZZ=$$SETSTR^VALM1(T,ZZ,13,$LENGTH(T))