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 ---[H[J[2J[HPSAVERA 9994 printed Nov 22, 2024@17:01:18 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)=""
+13 IF $ORDER(PSAMV(PSAMVA))'=""
SET DIR("L",PSA+2)=$JUSTIFY(PSA,2)_" "_PSAMVA
+14 IF '$TEST
SET DIR("L")=$JUSTIFY(PSA,2)_" "_PSAMVA
+15 SET DIR(0)=DIR(0)_PSA_":"_PSAMVA_";"
End DoDot:2
End DoDot:1
+16 SET DIR("A")="Master Vault"
SET DIR("?")="Select the Master Vault that received the invoice's drugs."
+17 SET DIR("??")="^D MV^PSAPROC"
DO ^DIR
KILL DIR
if Y=""
QUIT
IF $GET(DIRUT)
SET PSAOUT=1
QUIT
+18 SET PSASEL=Y
+19 SET PSAMVA=$ORDER(PSAVAULT(PSASEL,""))
if PSAMVA=""
QUIT
SET PSACSLOC=+$ORDER(PSAVAULT(PSASEL,PSAMVA,0))
+20 QUIT
