PSAVERA.m

PSAVERA ;BHM/DBM - Change verified invoice data;16AUG05

 ;;3.0;DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**21,36,40,53,63,70,80**; 10/24/97;Build 2

 ;

 ;References to ^DIC(51.5 are covered by IA #1931

 ;References to ^PSDRUG( are covered by IA #2095

 D Q

 D HOME^%ZIS S XX="VERIFIED INVOICE ALTERATION SCREEN" W @IOF,!!,?((IOM/2)-($L(XX)/2)),XX,!!

ORDR ;Get Order Number

 S DIC(0)="AEQMZ",DIC("A")="Select Order Number: ",DIC="^PSD(58.811," D ^DIC K DIC G Q:+Y'>0 S PSAIEN=+Y,PSAORD=$P(Y,U,2)

 ;

INV ;Get Invoice Number

 S DIC(0)="AEQMZ",DIC("A")="Select Invoice Number: ",DIC="^PSD(58.811,"_PSAIEN_",1,",D="ASTAT" D ^DIC K DIC G Q:+Y'>0 S PSAIEN1=+Y,PSAINV=$P(Y,U,2)

 S DATA=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,0))

 S PSALOC=$S($P(DATA,"^",12)'="":$P(DATA,"^",12),1:$P(DATA,"^",5)) I $G(PSALOC)="" S PSALOC="No Location identified"

 D ^PSAVERA1

 K DATA,PSAITM,LINENUM,PSALIDAT,X,X1,X2,X3,DIC,DA,DR D HDR

DISP S PSAITM=$S('$D(PSAITM):$O(INVARRAY(PSAORD,PSAINV,0)),1:$O(INVARRAY(PSAORD,PSAINV,PSAITM))) G LINEASK:PSAITM'>0 S LINENUM=$G(LINENUM)+1

 S DATA=$G(INVARRAY(PSAORD,PSAINV,PSAITM)),PSAOU=$P(DATA,"^",4) I $G(PSAOU) S PSAOU(1)=$P($G(^DIC(51.5,$P(DATA,"^",4),0)),"^") ;Current Order Unit  ;; <*63 RJS

 W !,PSAITM,?6,$S($P($P(DATA,"^",1),"~",1)'>0:$P($P(DATA,"^",1),"~",1),1:$P($P(DATA,"^",1),"~",2)),?45,$S($G(PSAOU)="":"none",$G(PSAOU(1))'="":$G(PSAOU(1)),1:$G(PSAAOU)),?55,$J($P($G(DATA),"^",2),4),?61,$P(DATA,"^",5)  ;;<PSA*3*70 RJS

 I IOST["C-",$Y>(IOSL-5) S DIR(0)="E" D ^DIR G Q:$G(DUOUT)=1 D HDR

 G DISP

LINEASK ;ask for line number

 W !,"Enter the corresponding item number to edit: " R AN:DTIME I AN["^"!(AN="") G Q

 I AN<1!(AN>LINENUM) W !,"Enter a number between 1 & ",LINENUM,! G LINEASK

 I "?"[AN W !,"Select the number that corresponds to the line item that needs editing",! K AN G LINEASK

 S DATA=$G(INVARRAY(PSAORD,PSAINV,AN))

 S PSALINE=AN,PSAIN="NADA" I '$D(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,0)) W !,"Invalid line selection." G LINEASK

 S PSADATA=^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,0),PSASUP=0

 S PSALIDAT=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,0))

 S PSACS=0 S:+$P(PSADATA,"^",10) PSACS=$G(PSACS)+1

 S PSANDC=$P(PSADATA,"^",11)

 S PSALINEN="" D VERDISP^PSAUTL4 W !,PSASLN,!

 S PSAVEND=$P(^PSD(58.811,PSAIEN,0),"^",2)

 S PSAODUOU=PSADUOU

 ;; *63

 S PSA581="" F  S PSA581=$O(^PSD(58.81,"PV",PSAINV,PSA581)) Q:'PSA581  I $P(^PSD(58.81,PSA581,0),U,5)=PSADRG S PSABFR(581)=$G(^PSD(58.81,PSA581,0))

 S:$G(PSABFR(581)) PSDTRN=$P(PSABFR(581),U,1),PSABFR("Q")=$S($G(^PSD(58.81,PSDTRN,4)):$P(^PSD(58.81,PSDTRN,4),"^",3),1:$P(^PSD(58.81,PSDTRN,0),"^",6)) ; <*63 RJS >

DRG W !,"Select (D)rug or (O)rder Unit " R AN:DTIME G Q:AN["^"!(AN="") W $S("Dd"[AN:"rug","oO"[AN:"rder Unit",1:"??") I "DdOo"'[AN W !,"Enter a 'D' to edit the Drug, or 'O' to edit the order unit",! K AN G DRG

 I "Dd"'[AN D ^PSAVERA3 G Q  ;;*63

 ;Get either new name of drug or supply item description

 S PSABFR=$P(DATA,"~",1),PSABFR(1)=$S(PSABFR'?.N:PSABFR,1:$P($P(DATA,"^"),"~",2)),PSABFR("NDC")=$P(PSADATA,"^",11)  ;;*63

DRGAGN D

 .S X1=0 F  S X1=$O(^PSDRUG(PSABFR,1,X1)) Q:X1'>0  S DATA=$G(^PSDRUG(PSABFR,1,X1,0)) I $P(DATA,"^",2)=PSABFR("NDC") S PSABFR("SYNNODE")=X1  ;;*63

 D PSANDC1^PSAHELP S PSADASH=PSANDCX K PSANDCX

 I $G(PSABFR("SYNNODE"))="",$E(PSABFR("NDC"))'="S" S PSABFR("NDC")="S"_PSABFR("NDC") G DRGAGN ;may be supply, try again

 I $G(PSABFR("SYNNODE"))'="" S PSASUB=PSABFR("SYNNODE") D

 .S DATA=$G(^PSDRUG(PSABFR,1,PSASUB,0)),PSAOU=$P(DATA,"^",5),PSAPOU=$P(DATA,"^",6),PSADUOU=$P(DATA,"^",7),PSAPDUOU=$P(DATA,"^",8)

 .S PSADU=$P($G(^PSDRUG(PSABFR,660)),"^",8)

 I ($G(PSAOU)=""!$G(PSAPOU)=""!$G(PSADUOU)=""!$G(PSAPDUOU)="") W !!,"Sorry, I could not find the necessary information to change the drug selection.",! G Q

 W !,"Current Drug : ",PSABFR(1)

DRG1 S PSAGAIN=0,DIC("A")="Select name of Correct Drug: ",PSABFR=PSADRG,DIC(0)="AEQMZ",DIC="^PSDRUG(" D ^DIC K DIC G Q:PSAOUT

 I $G(DTOUT)!($G(DUOT))!(Y<0) S PSAOUT=1 Q

 S (PSADJ,PSADRG)=+Y

 W !!,"Comparing drug file data..."

 S PSAODU=$P($G(^PSDRUG(PSADRG,660)),"^",8),PSAXDUOU=$P($G(^PSDRUG(PSADRG,660)),"^",5)

 I $P($G(^PSDRUG(PSADRG,660)),"^",2)'=$G(PSAOU) W !,"The Order Units are different between these two drugs."

 I $P($G(^PSDRUG(PSADRG,660)),"^",8)'=$G(PSADU) W !,"Please Enter an appropriate Dispense Unit" S DIE="^PSDRUG(",DA=PSADRG,DR="14.5" D ^DIE S PSADU=$P(^PSDRUG(PSADRG,660),"^",8)

 I $P($G(^PSDRUG(PSADRG,660)),"^",5)'=$G(PSADUOU) W !,"Please enter the appropriate Dispense Units per order unit" S DIE="^PSDRUG(",DA=PSADRG,DR="15" D ^DIE S PSADUOU=$P(^PSDRUG(PSADRG,660),"^",5)

 K DIE,DA,DR N PSACSLOC,PSANCSLO

 S PSACSLOC=+$P(^PSD(58.811,PSAIEN,1,PSAIEN1,0),"^",12)

 I 'PSACSLOC,$P($G(^PSDRUG(PSADRG,2)),"^",3)["N" D MSTVAULT I $G(PSAOUT)!'PSACSLOC G NOCHNG

 S PSANCSLO=+$P(^PSD(58.811,PSAIEN,1,PSAIEN1,0),"^",5)

 I 'PSANCSLO,$P($G(^PSDRUG(PSADRG,2)),"^",3)'["N" D PHARMLOC I $G(PSAOUT)!'PSANCSLO G NOCHNG

 ;

ASK R !!,"Are you sure about this ?  NO// ",AN:DTIME G NOCHNG:AN["^"!(AN="")

 S AN=$E(AN) I "yYnN"'[AN W !,"Answer yes, and the data on file for the current drug will be transferred",!,"to the new drug selection.",!,"That includes Order Unit, Dispense Unit, Dispense Units per Order Unit, etc.",!! G ASK

 I "Nn"[AN G NOCHNG ;*53

 S PSAAFTER=PSADRG,PSADRG=PSABFR

 I $D(^PSDRUG(PSADRG))&$G(PSABFR(581)) D

 .W !,"Removing "_PSABFR("Q")_" from "_PSABFR(1)

 .S FMDATA=$P($G(^PSDRUG(PSADRG,660.1)),"^")-PSABFR("Q"),DIE="^PSDRUG(",DA=PSADRG,DR="50////^S X="_FMDATA

 .F  L +^PSDRUG(DA,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I  Q

 .D ^DIE L -^PSDRUG(DA,0) K FMDATA

 S PSADRG=PSAAFTER

 I $G(PSAPOU)="",$G(PSAPRICE)'="" S PSAPOU=PSAPRICE

 W !,"Adding "_($G(PSAQTY)*$G(PSADUOU))_" to "_$P($G(^PSDRUG(PSADRG,0)),"^")

 W !,"Entering new drug selection as an adjustment."

 S PSAREA="",PSADJFLD="D",PSADJ=PSADRG D RECORD^PSAVER2,50^PSAVER7

FILE ;File dispense units per order units into 58.811

 S DIE="^PSD(58.811,"_PSAIEN_",1,"_PSAIEN1_",1,",DA=PSALINE,DA(1)=PSAIEN1,DA(2)=PSAIEN,DR="10///"_PSADUOU D ^DIE

 G:$D(^PSD(58.811,"ASTAT","P",PSAIEN,PSAIEN1)) Q  ;; *63 RJS

 D UPDATE^PSAVERA1 G Q

 ;

HDR W @IOF,!?25,"EDIT VERIFIED INVOICED ITEM SCREEN",!,PSASLN,!

 W !,?44,"Order",!,"#",?6,"Drug/Item Name",?45,"Unit",?56,"Qnty.",?67,"NDC",!,PSASLN,! Q  ;; <- PSA*3*70 RJS

Q K AN,D,DA,DATA,DIC,DIR,INVARRAY,LINENUM,POP,PSA50IEN,PSA581,PSAABAL,PSAAFTER,PSAAQTY,PSABAL,PSABFR,PSACS,PSADASH,PSADATA,PSADJ,PSADJD,PSADJFLD,PSADJO,PSADJP,PSADJQ,PSADRG,PSADRUGN,PSADT

 K PSADU,PSADUOU,PSADUREC,PSAEDTT,PSAGAIN,PSAIEN,PSAIEN1,PSAIN,PSAINV,PSAITM,PSALINE,PSALINEN,PSALOC,PSANDC,PSANDUOU,PSANEW,PSANODE,PSANPDU,PSANQTY,PSAODASH,PSAODU,PSAODUOU,PSAONDC,PSAORD

 K PSAOU,PSAOUT,PSAPOU,PSAPRICE,PSAQTY,PSAREA,PSAREORD,PSASET,PSASLN,PSASTOCK,PSASUB,PSASUP,PSASUPP,PSAT,PSATEMP,PSAUPC,PSAVDUZ,PSAVEND,PSAVER,PSAVSN,PSAXDUOU,PSDTRN,X,X1,X2,X3,XX,XXX,Y

 Q

NOCHNG ;*53 said no to changes, backout the edits on the new drug choice.

 K DIE,DR,DA

 S DIE="^PSDRUG(",DA=PSADRG,DR="14.5////^S X=PSAODU;15////^S X=PSAXDUOU" D ^DIE

 W !,"NO CHANGE",! G Q

 ;

PHARMLOC ; Prompt User for Pharmacy Location (Needed for edits from CS Drugs to Non-CS Drugs)

 N DIR,DIRUT,PSALOC,PSANUM,PSALOCA,PSANLOC,PSALOCN,PSAMENU,PSAMENU,PSAISITN,PSAISIT,PSACOMB,PSACNT,PSAONE,PSAOSIT,PSAOSITN,PSASEL,XX,X,Y

 S (PSALOC,PSANUM)=0 F  S PSALOC=+$O(^PSD(58.8,"ADISP","P",PSALOC)) Q:'PSALOC  D

 .Q:'$D(^PSD(58.8,PSALOC,0))!($P($G(^PSD(58.8,PSALOC,0)),"^")="")

 .I +$G(^PSD(58.8,PSALOC,"I")),+^PSD(58.8,PSALOC,"I")'>DT Q

 .S PSANUM=PSANUM+1,PSAONE=PSALOC,PSAISIT=+$P(^PSD(58.8,PSALOC,0),"^",3),PSAOSIT=+$P(^(0),"^",10)

 .D SITES^PSAUTL1 S PSALOCA($P(^PSD(58.8,PSALOC,0),"^")_PSACOMB,PSALOC)=PSAISIT_"^"_PSAOSIT

 ; W @IOF,!?19,"<<< ASSIGN A PHARMACY LOCATION SCREEN >>>",!

 S DIR(0)="S^"

 S DIR("L",1)="Select a Pharmacy Location for the new Drug:"

 S DIR("L",2)="Choose from:"

 S PSACNT=0,PSALOCN="" F  S PSALOCN=$O(PSALOCA(PSALOCN)) Q:PSALOCN=""  D

 . S PSALOC=0 F  S PSALOC=$O(PSALOCA(PSALOCN,PSALOC)) Q:'PSALOC  D

 . . S PSACNT=PSACNT+1,PSAMENU(PSACNT,PSALOCN,PSALOC)=PSALOC

 . . I $O(PSALOCA(PSALOCN))'="" S DIR("L",PSACNT+2)=$J(PSACNT,2)_"   "_$S($L(PSALOCN)>72:$P(PSALOCN,"(IP)",1)_"(IP)    "_$P(PSALOCN,"(IP)",2),1:PSALOCN)

 . . E  S DIR("L")=$J(PSACNT,2)_"   "_$S($L(PSALOCN)>72:$P(PSALOCN,"(IP)",1)_"(IP)    "_$P(PSALOCN,"(IP)",2),1:PSALOCN)

 . . S DIR(0)=DIR(0)_PSACNT_":"_$S($L(PSALOCN)>72:$P(PSALOCN,"(IP)",1)_"(IP)    "_$P(PSALOCN,"(IP)",2),1:PSALOCN)_";"

 S DIR("A")="Pharmacy Location",DIR("?")="Select the pharmacy location that received the invoice's drugs"

 S DIR("??")="^D LOCHELP^PSAVER5" D ^DIR K DIR Q:Y=""  I $G(DIRUT) S PSAOUT=1

 S PSASEL=Y

 S PSALOCN=$O(PSAMENU(PSASEL,"")) Q:PSALOCN=""  S PSANCSLO=$O(PSAMENU(PSASEL,PSALOCN,0))

 Q

 ;

MSTVAULT ; Prompt User for Master Vault (Needed for edits from Non-CS Drugs to CS Drugs)

 N DIR,PSA,PSAMV,PSAMVA,PSAMVIEN,PSAMVN,PSAONEMV,PSASEL,PSAVAULT,X,Y

 S (PSAMVN,PSAMV)=0 F  S PSAMV=+$O(^PSD(58.8,"ADISP","M",PSAMV)) Q:'PSAMV  D

 . S PSAMVN=PSAMVN+1,PSAONEMV=PSAMV,PSAMV($P(^PSD(58.8,PSAMV,0),"^"),PSAMV)=""

 I 'PSAMVN D  S PSAOUT=1 Q

 . W !!,"No master vaults are set up. You must set up a master vault then"

 . W !,"select the Process Uploaded Prime Vendor Invoices Data option."

 S DIR(0)="S^"

 S DIR("L",1)="Select a Master Vault for the new Drug:"

 S DIR("L",2)="Choose from:"

 S PSA=0,PSAMVA="" F  S PSAMVA=$O(PSAMV(PSAMVA)) Q:PSAMVA=""  D

 . S PSAMVIEN=0 F  S PSAMVIEN=$O(PSAMV(PSAMVA,PSAMVIEN)) Q:'PSAMVIEN  D

 . . S PSA=PSA+1,PSAVAULT(PSA,PSAMVA,PSAMVIEN)=""

 . . I $O(PSAMV(PSAMVA))'="" S DIR("L",PSA+2)=$J(PSA,2)_"   "_PSAMVA

 . . E  S DIR("L")=$J(PSA,2)_"   "_PSAMVA

 . . S DIR(0)=DIR(0)_PSA_":"_PSAMVA_";"

 S DIR("A")="Master Vault",DIR("?")="Select the Master Vault that received the invoice's drugs."

 S DIR("??")="^D MV^PSAPROC" D ^DIR K DIR Q:Y=""  I $G(DIRUT) S PSAOUT=1 Q

 S PSASEL=Y

 S PSAMVA=$O(PSAVAULT(PSASEL,"")) Q:PSAMVA=""  S PSACSLOC=+$O(PSAVAULT(PSASEL,PSAMVA,0))

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PSAVERA   9994     printed  Mar 13, 2025@20:55:47                                                                                                                                                                                                     Page 2

PSAVERA   ;BHM/DBM - Change verified invoice data;16AUG05

 +1       ;;3.0;DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**21,36,40,53,63,70,80**; 10/24/97;Build 2

 +2       ;

 +3       ;References to ^DIC(51.5 are covered by IA #1931

 +4       ;References to ^PSDRUG( are covered by IA #2095

 +5        DO Q

 +6        DO HOME^%ZIS

           SET XX="VERIFIED INVOICE ALTERATION SCREEN"

           WRITE @IOF,!!,?((IOM/2)-($LENGTH(XX)/2)),XX,!!

ORDR      ;Get Order Number

 +1        SET DIC(0)="AEQMZ"

           SET DIC("A")="Select Order Number: "

           SET DIC="^PSD(58.811,"

           DO ^DIC

           KILL DIC

           if +Y'>0

               GOTO Q

           SET PSAIEN=+Y

           SET PSAORD=$PIECE(Y,U,2)

 +2       ;

INV       ;Get Invoice Number

 +1        SET DIC(0)="AEQMZ"

           SET DIC("A")="Select Invoice Number: "

           SET DIC="^PSD(58.811,"_PSAIEN_",1,"

           SET D="ASTAT"

           DO ^DIC

           KILL DIC

           if +Y'>0

               GOTO Q

           SET PSAIEN1=+Y

           SET PSAINV=$PIECE(Y,U,2)

 +2        SET DATA=$GET(^PSD(58.811,PSAIEN,1,PSAIEN1,0))

 +3        SET PSALOC=$SELECT($PIECE(DATA,"^",12)'="":$PIECE(DATA,"^",12),1:$PIECE(DATA,"^",5))

           IF $GET(PSALOC)=""

               SET PSALOC="No Location identified"

 +4        DO ^PSAVERA1

 +5        KILL DATA,PSAITM,LINENUM,PSALIDAT,X,X1,X2,X3,DIC,DA,DR

           DO HDR

DISP       SET PSAITM=$SELECT('$DATA(PSAITM):$ORDER(INVARRAY(PSAORD,PSAINV,0)),1:$ORDER(INVARRAY(PSAORD,PSAINV,PSAITM)))

           if PSAITM'>0

               GOTO LINEASK

           SET LINENUM=$GET(LINENUM)+1

 +1       ;Current Order Unit  ;; <*63 RJS

           SET DATA=$GET(INVARRAY(PSAORD,PSAINV,PSAITM))

           SET PSAOU=$PIECE(DATA,"^",4)

           IF $GET(PSAOU)

               SET PSAOU(1)=$PIECE($GET(^DIC(51.5,$PIECE(DATA,"^",4),0)),"^")

 +2       ;;<PSA*3*70 RJS

          WRITE !,PSAITM,?6,$SELECT($PIECE($PIECE(DATA,"^",1),"~",1)'>0:$PIECE($PIECE(DATA,"^",1),"~",1),1:$PIECE($PIECE(DATA,"^",1),"~",2)),?45,$SELECT(...

           ... $GET(PSAOU)="":"none",$GET(PSAOU(1))'="":$GET(PSAOU(1)),1:$GET(PSAAOU)),?55,$JUSTIFY($PIECE($GET(DATA),"^",2),4),?61,$PIECE(DATA,"^",5)

 +3        IF IOST["C-"

               IF $Y>(IOSL-5)

                   SET DIR(0)="E"

                   DO ^DIR

                   if $GET(DUOUT)=1

                       GOTO Q

                   DO HDR

 +4        GOTO DISP

LINEASK   ;ask for line number

 +1        WRITE !,"Enter the corresponding item number to edit: "

           READ AN:DTIME

           IF AN["^"!(AN="")

               GOTO Q

 +2        IF AN<1!(AN>LINENUM)

               WRITE !,"Enter a number between 1 & ",LINENUM,!

               GOTO LINEASK

 +3        IF "?"[AN

               WRITE !,"Select the number that corresponds to the line item that needs editing",!

               KILL AN

               GOTO LINEASK

 +4        SET DATA=$GET(INVARRAY(PSAORD,PSAINV,AN))

 +5        SET PSALINE=AN

           SET PSAIN="NADA"

           IF '$DATA(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,0))

               WRITE !,"Invalid line selection."

               GOTO LINEASK

 +6        SET PSADATA=^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,0)

           SET PSASUP=0

 +7        SET PSALIDAT=$GET(^PSD(58.811,PSAIEN,1,PSAIEN1,0))

 +8        SET PSACS=0

           if +$PIECE(PSADATA,"^",10)

               SET PSACS=$GET(PSACS)+1

 +9        SET PSANDC=$PIECE(PSADATA,"^",11)

 +10       SET PSALINEN=""

           DO VERDISP^PSAUTL4

           WRITE !,PSASLN,!

 +11       SET PSAVEND=$PIECE(^PSD(58.811,PSAIEN,0),"^",2)

 +12       SET PSAODUOU=PSADUOU

 +13      ;; *63

 +14       SET PSA581=""

           FOR 

               SET PSA581=$ORDER(^PSD(58.81,"PV",PSAINV,PSA581))

               if 'PSA581

                   QUIT 

               IF $PIECE(^PSD(58.81,PSA581,0),U,5)=PSADRG

                   SET PSABFR(581)=$GET(^PSD(58.81,PSA581,0))

 +15      ; <*63 RJS >

           if $GET(PSABFR(581))

               SET PSDTRN=$PIECE(PSABFR(581),U,1)

               SET PSABFR("Q")=$SELECT($GET(^PSD(58.81,PSDTRN,4)):$PIECE(^PSD(58.81,PSDTRN,4),"^",3),1:$PIECE(^PSD(58.81,PSDTRN,0),"^",6))

DRG        WRITE !,"Select (D)rug or (O)rder Unit "

           READ AN:DTIME

           if AN["^"!(AN="")

               GOTO Q

           WRITE $SELECT("Dd"[AN:"rug","oO"[AN:"rder Unit",1:"??")

           IF "DdOo"'[AN

               WRITE !,"Enter a 'D' to edit the Drug, or 'O' to edit the order unit",!

               KILL AN

               GOTO DRG

 +1       ;;*63

           IF "Dd"'[AN

               DO ^PSAVERA3

               GOTO Q

 +2       ;Get either new name of drug or supply item description

 +3       ;;*63

           SET PSABFR=$PIECE(DATA,"~",1)

           SET PSABFR(1)=$SELECT(PSABFR'?.N:PSABFR,1:$PIECE($PIECE(DATA,"^"),"~",2))

           SET PSABFR("NDC")=$PIECE(PSADATA,"^",11)

DRGAGN     Begin DoDot:1

 +1       ;;*63

               SET X1=0

               FOR 

                   SET X1=$ORDER(^PSDRUG(PSABFR,1,X1))

                   if X1'>0

                       QUIT 

                   SET DATA=$GET(^PSDRUG(PSABFR,1,X1,0))

                   IF $PIECE(DATA,"^",2)=PSABFR("NDC")

                       SET PSABFR("SYNNODE")=X1

           End DoDot:1

 +2        DO PSANDC1^PSAHELP

           SET PSADASH=PSANDCX

           KILL PSANDCX

 +3       ;may be supply, try again

           IF $GET(PSABFR("SYNNODE"))=""

               IF $EXTRACT(PSABFR("NDC"))'="S"

                   SET PSABFR("NDC")="S"_PSABFR("NDC")

                   GOTO DRGAGN

 +4        IF $GET(PSABFR("SYNNODE"))'=""

               SET PSASUB=PSABFR("SYNNODE")

               Begin DoDot:1

 +5                SET DATA=$GET(^PSDRUG(PSABFR,1,PSASUB,0))

                   SET PSAOU=$PIECE(DATA,"^",5)

                   SET PSAPOU=$PIECE(DATA,"^",6)

                   SET PSADUOU=$PIECE(DATA,"^",7)

                   SET PSAPDUOU=$PIECE(DATA,"^",8)

 +6                SET PSADU=$PIECE($GET(^PSDRUG(PSABFR,660)),"^",8)

               End DoDot:1

 +7        IF ($GET(PSAOU)=""!$GET(PSAPOU)=""!$GET(PSADUOU)=""!$GET(PSAPDUOU)="")

               WRITE !!,"Sorry, I could not find the necessary information to change the drug selection.",!

               GOTO Q

 +8        WRITE !,"Current Drug : ",PSABFR(1)

DRG1       SET PSAGAIN=0

           SET DIC("A")="Select name of Correct Drug: "

           SET PSABFR=PSADRG

           SET DIC(0)="AEQMZ"

           SET DIC="^PSDRUG("

           DO ^DIC

           KILL DIC

           if PSAOUT

               GOTO Q

 +1        IF $GET(DTOUT)!($GET(DUOT))!(Y<0)

               SET PSAOUT=1

               QUIT 

 +2        SET (PSADJ,PSADRG)=+Y

 +3        WRITE !!,"Comparing drug file data..."

 +4        SET PSAODU=$PIECE($GET(^PSDRUG(PSADRG,660)),"^",8)

           SET PSAXDUOU=$PIECE($GET(^PSDRUG(PSADRG,660)),"^",5)

 +5        IF $PIECE($GET(^PSDRUG(PSADRG,660)),"^",2)'=$GET(PSAOU)

               WRITE !,"The Order Units are different between these two drugs."

 +6        IF $PIECE($GET(^PSDRUG(PSADRG,660)),"^",8)'=$GET(PSADU)

               WRITE !,"Please Enter an appropriate Dispense Unit"

               SET DIE="^PSDRUG("

               SET DA=PSADRG

               SET DR="14.5"

               DO ^DIE

               SET PSADU=$PIECE(^PSDRUG(PSADRG,660),"^",8)

 +7        IF $PIECE($GET(^PSDRUG(PSADRG,660)),"^",5)'=$GET(PSADUOU)

               WRITE !,"Please enter the appropriate Dispense Units per order unit"

               SET DIE="^PSDRUG("

               SET DA=PSADRG

               SET DR="15"

               DO ^DIE

               SET PSADUOU=$PIECE(^PSDRUG(PSADRG,660),"^",5)

 +8        KILL DIE,DA,DR

           NEW PSACSLOC,PSANCSLO

 +9        SET PSACSLOC=+$PIECE(^PSD(58.811,PSAIEN,1,PSAIEN1,0),"^",12)

 +10       IF 'PSACSLOC

               IF $PIECE($GET(^PSDRUG(PSADRG,2)),"^",3)["N"

                   DO MSTVAULT

                   IF $GET(PSAOUT)!'PSACSLOC

                       GOTO NOCHNG

 +11       SET PSANCSLO=+$PIECE(^PSD(58.811,PSAIEN,1,PSAIEN1,0),"^",5)

 +12       IF 'PSANCSLO

               IF $PIECE($GET(^PSDRUG(PSADRG,2)),"^",3)'["N"

                   DO PHARMLOC

                   IF $GET(PSAOUT)!'PSANCSLO

                       GOTO NOCHNG

 +13      ;

ASK        READ !!,"Are you sure about this ?  NO// ",AN:DTIME

           if AN["^"!(AN="")

               GOTO NOCHNG

 +1        SET AN=$EXTRACT(AN)

           IF "yYnN"'[AN

               WRITE !,"Answer yes, and the data on file for the current drug will be transferred",!,"to the new drug selection.",!,"That includes Order Unit, Dispense Unit, Dispense Units per Order Unit, etc.",!!

               GOTO ASK

 +2       ;*53

           IF "Nn"[AN

               GOTO NOCHNG

 +3        SET PSAAFTER=PSADRG

           SET PSADRG=PSABFR

 +4        IF $DATA(^PSDRUG(PSADRG))&$GET(PSABFR(581))

               Begin DoDot:1

 +5                WRITE !,"Removing "_PSABFR("Q")_" from "_PSABFR(1)

 +6                SET FMDATA=$PIECE($GET(^PSDRUG(PSADRG,660.1)),"^")-PSABFR("Q")

                   SET DIE="^PSDRUG("

                   SET DA=PSADRG

                   SET DR="50////^S X="_FMDATA

 +7                FOR 

                       LOCK +^PSDRUG(DA,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)

                      IF $TEST

                           QUIT 

 +8                DO ^DIE

                   LOCK -^PSDRUG(DA,0)

                   KILL FMDATA

               End DoDot:1

 +9        SET PSADRG=PSAAFTER

 +10       IF $GET(PSAPOU)=""

               IF $GET(PSAPRICE)'=""

                   SET PSAPOU=PSAPRICE

 +11       WRITE !,"Adding "_($GET(PSAQTY)*$GET(PSADUOU))_" to "_$PIECE($GET(^PSDRUG(PSADRG,0)),"^")

 +12       WRITE !,"Entering new drug selection as an adjustment."

 +13       SET PSAREA=""

           SET PSADJFLD="D"

           SET PSADJ=PSADRG

           DO RECORD^PSAVER2

           DO 50^PSAVER7

FILE      ;File dispense units per order units into 58.811

 +1        SET DIE="^PSD(58.811,"_PSAIEN_",1,"_PSAIEN1_",1,"

           SET DA=PSALINE

           SET DA(1)=PSAIEN1

           SET DA(2)=PSAIEN

           SET DR="10///"_PSADUOU

           DO ^DIE

 +2       ;; *63 RJS

           if $DATA(^PSD(58.811,"ASTAT","P",PSAIEN,PSAIEN1))

               GOTO Q

 +3        DO UPDATE^PSAVERA1

           GOTO Q

 +4       ;

HDR        WRITE @IOF,!?25,"EDIT VERIFIED INVOICED ITEM SCREEN",!,PSASLN,!

 +1       ;; <- PSA*3*70 RJS

           WRITE !,?44,"Order",!,"#",?6,"Drug/Item Name",?45,"Unit",?56,"Qnty.",?67,"NDC",!,PSASLN,!

           QUIT 

Q          KILL AN,D,DA,DATA,DIC,DIR,INVARRAY,LINENUM,POP,PSA50IEN,PSA581,PSAABAL,PSAAFTER,PSAAQTY,PSABAL,PSABFR,PSACS,PSADASH,PSADATA,PSADJ,PSADJD,PSADJFLD,PSADJO,PSADJP,PSADJQ,PSADRG,PSADRUGN,PSADT

 +1        KILL PSADU,PSADUOU,PSADUREC,PSAEDTT,PSAGAIN,PSAIEN,PSAIEN1,PSAIN,PSAINV,PSAITM,PSALINE,PSALINEN,PSALOC,PSANDC,PSANDUOU,PSANEW,PSANODE,PSANPDU,PSANQTY,PSAODASH,PSAODU,PSAODUOU,PSAONDC,PSAORD

 +2        KILL PSAOU,PSAOUT,PSAPOU,PSAPRICE,PSAQTY,PSAREA,PSAREORD,PSASET,PSASLN,PSASTOCK,PSASUB,PSASUP,PSASUPP,PSAT,PSATEMP,PSAUPC,PSAVDUZ,PSAVEND,PSAVER,PSAVSN,PSAXDUOU,PSDTRN,X,X1,X2,X3,XX,XXX,Y

 +3        QUIT 

NOCHNG    ;*53 said no to changes, backout the edits on the new drug choice.

 +1        KILL DIE,DR,DA

 +2        SET DIE="^PSDRUG("

           SET DA=PSADRG

           SET DR="14.5////^S X=PSAODU;15////^S X=PSAXDUOU"

           DO ^DIE

 +3        WRITE !,"NO CHANGE",!

           GOTO Q

 +4       ;

PHARMLOC  ; Prompt User for Pharmacy Location (Needed for edits from CS Drugs to Non-CS Drugs)

 +1        NEW DIR,DIRUT,PSALOC,PSANUM,PSALOCA,PSANLOC,PSALOCN,PSAMENU,PSAMENU,PSAISITN,PSAISIT,PSACOMB,PSACNT,PSAONE,PSAOSIT,PSAOSITN,PSASEL,XX,X,Y

 +2        SET (PSALOC,PSANUM)=0

           FOR 

               SET PSALOC=+$ORDER(^PSD(58.8,"ADISP","P",PSALOC))

               if 'PSALOC

                   QUIT 

               Begin DoDot:1

 +3                if '$DATA(^PSD(58.8,PSALOC,0))!($PIECE($GET(^PSD(58.8,PSALOC,0)),"^")="")

                       QUIT 

 +4                IF +$GET(^PSD(58.8,PSALOC,"I"))

                       IF +^PSD(58.8,PSALOC,"I")'>DT

                           QUIT 

 +5                SET PSANUM=PSANUM+1

                   SET PSAONE=PSALOC

                   SET PSAISIT=+$PIECE(^PSD(58.8,PSALOC,0),"^",3)

                   SET PSAOSIT=+$PIECE(^(0),"^",10)

 +6                DO SITES^PSAUTL1

                   SET PSALOCA($PIECE(^PSD(58.8,PSALOC,0),"^")_PSACOMB,PSALOC)=PSAISIT_"^"_PSAOSIT

               End DoDot:1

 +7       ; W @IOF,!?19,"<<< ASSIGN A PHARMACY LOCATION SCREEN >>>",!

 +8        SET DIR(0)="S^"

 +9        SET DIR("L",1)="Select a Pharmacy Location for the new Drug:"

 +10       SET DIR("L",2)="Choose from:"

 +11       SET PSACNT=0

           SET PSALOCN=""

           FOR 

               SET PSALOCN=$ORDER(PSALOCA(PSALOCN))

               if PSALOCN=""

                   QUIT 

               Begin DoDot:1

 +12               SET PSALOC=0

                   FOR 

                       SET PSALOC=$ORDER(PSALOCA(PSALOCN,PSALOC))

                       if 'PSALOC

                           QUIT 

                       Begin DoDot:2

 +13                       SET PSACNT=PSACNT+1

                           SET PSAMENU(PSACNT,PSALOCN,PSALOC)=PSALOC

 +14                       IF $ORDER(PSALOCA(PSALOCN))'=""

                               SET DIR("L",PSACNT+2)=$JUSTIFY(PSACNT,2)_"   "_$SELECT($LENGTH(PSALOCN)>72:$PIECE(PSALOCN,"(IP)",1)_"(IP)    "_$PIECE(PSALOCN,"(IP)",2),1:PSALOCN)

 +15                      IF '$TEST

                               SET DIR("L")=$JUSTIFY(PSACNT,2)_"   "_$SELECT($LENGTH(PSALOCN)>72:$PIECE(PSALOCN,"(IP)",1)_"(IP)    "_$PIECE(PSALOCN,"(IP)",2),1:PSALOCN)

 +16                       SET DIR(0)=DIR(0)_PSACNT_":"_$SELECT($LENGTH(PSALOCN)>72:$PIECE(PSALOCN,"(IP)",1)_"(IP)    "_$PIECE(PSALOCN,"(IP)",2),1:PSALOCN)_";"

                       End DoDot:2

               End DoDot:1

 +17       SET DIR("A")="Pharmacy Location"

           SET DIR("?")="Select the pharmacy location that received the invoice's drugs"

 +18       SET DIR("??")="^D LOCHELP^PSAVER5"

           DO ^DIR

           KILL DIR

           if Y=""

               QUIT 

           IF $GET(DIRUT)

               SET PSAOUT=1

 +19       SET PSASEL=Y

 +20       SET PSALOCN=$ORDER(PSAMENU(PSASEL,""))

           if PSALOCN=""

               QUIT 

           SET PSANCSLO=$ORDER(PSAMENU(PSASEL,PSALOCN,0))

 +21       QUIT 

 +22      ;

MSTVAULT  ; Prompt User for Master Vault (Needed for edits from Non-CS Drugs to CS Drugs)

 +1        NEW DIR,PSA,PSAMV,PSAMVA,PSAMVIEN,PSAMVN,PSAONEMV,PSASEL,PSAVAULT,X,Y

 +2        SET (PSAMVN,PSAMV)=0

           FOR 

               SET PSAMV=+$ORDER(^PSD(58.8,"ADISP","M",PSAMV))

               if 'PSAMV

                   QUIT 

               Begin DoDot:1

 +3                SET PSAMVN=PSAMVN+1

                   SET PSAONEMV=PSAMV

                   SET PSAMV($PIECE(^PSD(58.8,PSAMV,0),"^"),PSAMV)=""

               End DoDot:1

 +4        IF 'PSAMVN

               Begin DoDot:1

 +5                WRITE !!,"No master vaults are set up. You must set up a master vault then"

 +6                WRITE !,"select the Process Uploaded Prime Vendor Invoices Data option."

               End DoDot:1

               SET PSAOUT=1

               QUIT 

 +7        SET DIR(0)="S^"

 +8        SET DIR("L",1)="Select a Master Vault for the new Drug:"

 +9        SET DIR("L",2)="Choose from:"

 +10       SET PSA=0

           SET PSAMVA=""

           FOR 

               SET PSAMVA=$ORDER(PSAMV(PSAMVA))

               if PSAMVA=""

                   QUIT 

               Begin DoDot:1

 +11               SET PSAMVIEN=0

                   FOR 

                       SET PSAMVIEN=$ORDER(PSAMV(PSAMVA,PSAMVIEN))

                       if 'PSAMVIEN

                           QUIT 

                       Begin DoDot:2

 +12                       SET PSA=PSA+1

                           SET PSAVAULT(PSA,PSAMVA,PSAMVIEN)=""