- PSAVERA ;BHM/DBM - Change verified invoice data;16AUG05
- ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**21,36,40,53**; 10/24/97
- ;
- ;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,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))
- S PSAOU=$P(DATA,"^",4) I $G(PSAOU) S PSAOU(1)=$P($G(^DIC(51.5,$P(DATA,"^",4),0)),"^") ;Current Order Unit
- W !,PSAITM,?10,$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)
- 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 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)
- ;VMP OIFO BAY PINES;VGF;PSA*3.0*40;GET ORIGINAL DISPENSE UNITS PER ORDER UNIT FOR SUBTRACTION
- S PSAODUOU=PSADUOU
- ;
- 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 G ^PSAVERA3
- ;Get either new name of drug or supply item description
- S PSABEFOR=$P(DATA,"~",1),PSABEFOR(1)=$S(PSABEFOR'?.N:PSABEFOR,1:$P($P(DATA,"^"),"~",2))
- S PSABEFOR("NDC")=$P(PSADATA,"^",11)
- DRGAGN D
- .S X1=0 F S X1=$O(^PSDRUG(PSABEFOR,1,X1)) Q:X1'>0 S DATA=$G(^PSDRUG(PSABEFOR,1,X1,0)) I $P(DATA,"^",2)=PSABEFOR("NDC") S PSABEFOR("SYNNODE")=X1
- D PSANDC1^PSAHELP S PSADASH=PSANDCX K PSANDCX
- I $G(PSABEFOR("SYNNODE"))="",$E(PSABEFOR("NDC"))'="S" S PSABEFOR("NDC")="S"_PSABEFOR("NDC") G DRGAGN ;may be supply, try again
- I $G(PSABEFOR("SYNNODE"))'="" S PSASUB=PSABEFOR("SYNNODE") D
- .S DATA=$G(^PSDRUG(PSABEFOR,1,PSASUB,0)),PSAOU=$P(DATA,"^",5),PSAPOU=$P(DATA,"^",6),PSADUOU=$P(DATA,"^",7),PSAPDUOU=$P(DATA,"^",8)
- .S PSADU=$P($G(^PSDRUG(PSABEFOR,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 : ",PSABEFOR(1)
- DRG1 S PSAGAIN=0,DIC("A")="Select name of Correct Drug: ",PSABEFOR=PSADRG,DIC(0)="AEQMZ",DIC="^PSDRUG(" D ^DIC K DIC G Q:PSAOUT
- I $G(DTOUT)!($G(DUOT)) 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)
- ;VMP OIFO BAY PINES;VGF;PSA*3.0*36
- 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
- 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
- ;VMP OIFO BAY PINES;VGF;PSA*3.0*36
- S PSAAFTER=PSADRG,PSADRG=PSABEFOR
- I $D(^PSDRUG(PSADRG)) D
- .;VMP OIFO BAY PINES;VGF;PSA*3.0*40
- .W !,"Removing "_($G(PSAQTY)*$G(PSAODUOU))_" from "_PSABEFOR(1)
- .S FMDATA=$P($G(^PSDRUG(PSADRG,660.1)),"^")-(PSAODUOU*PSAQTY)
- .S DIE="^PSDRUG(",DA=PSADRG,DR="50////^S X="_FMDATA
- .F L +^PSDRUG(DA,0):0 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
- D 50^PSAVER7
- FILE ;File dispense units per order units into 58.811
- S DIE="^PSD(58.811,"_PSAIEN_",1,"_PSAIEN1_",1,"
- S DA=PSALINE,DA(1)=PSAIEN1,DA(2)=PSAIEN
- S DR="10///"_PSADUOU
- D ^DIE
- ;File data in 58.8
- ;PSALOC= Either PSALOC or PSALOCB
- ;VMP OIFO BAY PINES;VGF;PSA*3.0*40;UPDATE
- S PSADRG=PSABEFOR
- F L +^PSD(58.8,PSALOC,1,PSADRG,0):0 I Q
- S PSADUREC=PSAQTY*$G(PSAODUOU)
- S PSABAL=$P($G(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",4)
- S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",4)=PSABAL-PSADUREC
- L -^PSD(58.8,PSALOC,1,PSADRG,0)
- ;VMP OIFO BAY PINES;VGF;PSA*3.0*40;ADDED *$G(PSADUOU)
- S PSADRG=PSAAFTER
- S PSADUREC=PSAQTY*$G(PSADUOU)
- D NOW^%DTC S PSADT=+$E(%,1,14)
- I '$D(^PSD(58.8,PSALOC,1,PSADRG,0)) D
- .S:'$D(^PSD(58.8,PSALOC,1,0)) DIC("P")=$P(^DD(58.8,10,0),"^",2)
- .S DA(1)=PSALOC,DIC="^PSD(58.8,"_DA(1)_",1,",(DA,DINUM,X)=PSADRG,DIC(0)="L",DLAYGO=58.8 ;*53
- .F L +^PSD(58.8,PSALOC,0):0 I Q
- .D FILE^DICN L -^PSD(58.8,PSALOC,0) K DIC,DA,DLAYGO
- F L +^PSD(58.8,PSALOC,1,PSADRG,0):0 I Q
- S PSABAL=$P($G(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",4)
- I $P($G(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",1)'=PSADRG S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",1)=PSADRG
- S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",4)=PSADUREC+PSABAL
- I +$P($G(^PSD(58.8,PSALOC,0)),"^",14) D
- .I PSASTOCK'=$P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",3) S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",3)=PSASTOCK
- .I PSAREORD'=$P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",5) S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",5)=PSAREORD
- S:'$D(^PSD(58.8,PSALOC,1,PSADRG,5,0)) DIC("P")=$P(^DD(58.8001,20,0),"^",2)
- I '$D(^PSD(58.8,PSALOC,1,PSADRG,5,$E(DT,1,5)*100,0)) D
- .S DIC="^PSD(58.8,"_PSALOC_",1,"_PSADRG_",5,",DIC(0)="L",DIC("DR")="1////^S X=$G(PSABAL)",(X,DINUM)=$E(DT,1,5)*100,DA(2)=PSALOC,DA(1)=PSADRG,DLAYGO=58.8 D ^DIC K DIC
- .S X="T-1M" D ^%DT S DIC="^PSD(58.8,"_PSALOC_",1,"_PSADRG_",5,",DIC(0)="L",(X,DINUM)=$E(Y,1,5)*100 D ^DIC K DIC,DLAYGO S DA=+Y
- .S DA(2)=PSALOC,DA(1)=PSADRG,DIE="^PSD(58.8,"_DA(2)_",1,"_DA(1)_",5,",DR="3////^S X=$G(PSABAL)" D ^DIE K DIE
- S DA(2)=PSALOC,DA(1)=PSADRG,DIE="^PSD(58.8,"_DA(2)_",1,"_DA(1)_",5,",DA=$E(DT,1,5)*100,DR="5////^S X="_($P($G(^(0)),"^",3)+PSADUREC) D ^DIE K DIE
- L -^PSD(58.8,PSALOC,1,PSADRG,0)
- W !,"updating pharmacy location file."
- FILE581 ;Update transaction file
- S PSAVDUZ=DUZ
- 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)>0 S DR=DR_";100////^S X=PSACS"
- F L +^PSD(58.81,DA,0):0 I Q
- D ^DIE L -^PSD(58.81,DA,0) K DIE W !,"updating transaction file." Q
- ;
- HDR W @IOF,!?25,"EDIT VERIFIED INVOICED ITEM SCREEN",!,PSASLN,!
- W !,?44,"Order",!,"#",?10,"Drug/Item Name",?45,"Unit",?56,"Qnty.",?67,"NDC",!,PSASLN,! Q
- Q K AN,D,DA,DATA,DIC,DIR,INVARRAY,LINENUM,PSA50IEN,PSABAL,PSABEFOR,PSACS,PSADATA,PSADJ,PSADJFLD,PSADRG,PSADT,PSADUREC,PSAGAIN,PSAIEN,PSAIEN1,PSAIN,PSAINV,PSALINE,PSALINEN
- K PSALOC,PSANDC,PSAORD,PSAOUT,PSAQTY,PSAREA,PSAREORD,PSASLN,PSASTOCK,PSASUB,PSASUP,PSASUPP,PSAT,PSAVER,X,X1,X2,X3,XX,XXX,Y,PSAODUOU
- K PSAODU,PSAODUOU,PSAXDUOU
- 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
- PSAVERA ;BHM/DBM - Change verified invoice data;16AUG05
- +1 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**21,36,40,53**; 10/24/97
- +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 ;
- +3 SET DATA=$GET(^PSD(58.811,PSAIEN,1,PSAIEN1,0))
- +4 SET PSALOC=$SELECT($PIECE(DATA,"^",12)'="":$PIECE(DATA,"^",12),1:$PIECE(DATA,"^",5))
- IF $GET(PSALOC)=""
- SET PSALOC="No Location identified"
- +5 DO ^PSAVERA1
- +6 ;
- +7 KILL DATA,PSAITM,LINENUM,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 SET DATA=$GET(INVARRAY(PSAORD,PSAINV,PSAITM))
- +2 ;Current Order Unit
- SET PSAOU=$PIECE(DATA,"^",4)
- IF $GET(PSAOU)
- SET PSAOU(1)=$PIECE($GET(^DIC(51.5,$PIECE(DATA,"^",4),0)),"^")
- +3 WRITE !,PSAITM,?10,$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)
- +4 IF IOST["C-"
- IF $Y>(IOSL-5)
- SET DIR(0)="E"
- DO ^DIR
- IF $GET(DUOUT)=1
- GOTO Q
- DO HDR
- +5 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 PSACS=0
- IF +$PIECE(PSADATA,"^",10)
- SET PSACS=$GET(PSACS)+1
- +8 SET PSANDC=$PIECE(PSADATA,"^",11)
- +9 SET PSALINEN=""
- DO VERDISP^PSAUTL4
- WRITE !,PSASLN,!
- +10 SET PSAVEND=$PIECE(^PSD(58.811,PSAIEN,0),"^",2)
- +11 ;VMP OIFO BAY PINES;VGF;PSA*3.0*40;GET ORIGINAL DISPENSE UNITS PER ORDER UNIT FOR SUBTRACTION
- +12 SET PSAODUOU=PSADUOU
- +13 ;
- 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 IF "Dd"'[AN
- GOTO ^PSAVERA3
- +2 ;Get either new name of drug or supply item description
- +3 SET PSABEFOR=$PIECE(DATA,"~",1)
- SET PSABEFOR(1)=$SELECT(PSABEFOR'?.N:PSABEFOR,1:$PIECE($PIECE(DATA,"^"),"~",2))
- +4 SET PSABEFOR("NDC")=$PIECE(PSADATA,"^",11)
- DRGAGN Begin DoDot:1
- +1 SET X1=0
- FOR
- SET X1=$ORDER(^PSDRUG(PSABEFOR,1,X1))
- IF X1'>0
- QUIT
- SET DATA=$GET(^PSDRUG(PSABEFOR,1,X1,0))
- IF $PIECE(DATA,"^",2)=PSABEFOR("NDC")
- SET PSABEFOR("SYNNODE")=X1
- End DoDot:1
- +2 DO PSANDC1^PSAHELP
- SET PSADASH=PSANDCX
- KILL PSANDCX
- +3 ;may be supply, try again
- IF $GET(PSABEFOR("SYNNODE"))=""
- IF $EXTRACT(PSABEFOR("NDC"))'="S"
- SET PSABEFOR("NDC")="S"_PSABEFOR("NDC")
- GOTO DRGAGN
- +4 IF $GET(PSABEFOR("SYNNODE"))'=""
- SET PSASUB=PSABEFOR("SYNNODE")
- Begin DoDot:1
- +5 SET DATA=$GET(^PSDRUG(PSABEFOR,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(PSABEFOR,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 : ",PSABEFOR(1)
- DRG1 SET PSAGAIN=0
- SET DIC("A")="Select name of Correct Drug: "
- SET PSABEFOR=PSADRG
- SET DIC(0)="AEQMZ"
- SET DIC="^PSDRUG("
- DO ^DIC
- KILL DIC
- IF PSAOUT
- GOTO Q
- +1 IF $GET(DTOUT)!($GET(DUOT))
- 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 ;VMP OIFO BAY PINES;VGF;PSA*3.0*36
- +8 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)
- +9 KILL DIE,DA,DR
- 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 ;VMP OIFO BAY PINES;VGF;PSA*3.0*36
- +4 SET PSAAFTER=PSADRG
- SET PSADRG=PSABEFOR
- +5 IF $DATA(^PSDRUG(PSADRG))
- Begin DoDot:1
- +6 ;VMP OIFO BAY PINES;VGF;PSA*3.0*40
- +7 WRITE !,"Removing "_($GET(PSAQTY)*$GET(PSAODUOU))_" from "_PSABEFOR(1)
- +8 SET FMDATA=$PIECE($GET(^PSDRUG(PSADRG,660.1)),"^")-(PSAODUOU*PSAQTY)
- +9 SET DIE="^PSDRUG("
- SET DA=PSADRG
- SET DR="50////^S X="_FMDATA
- +10 FOR
- LOCK +^PSDRUG(DA,0):0
- IF $TEST
- QUIT
- +11 DO ^DIE
- +12 LOCK -^PSDRUG(DA,0)
- +13 KILL FMDATA
- End DoDot:1
- +14 SET PSADRG=PSAAFTER
- +15 IF $GET(PSAPOU)=""
- IF $GET(PSAPRICE)'=""
- SET PSAPOU=PSAPRICE
- +16 WRITE !,"Adding "_($GET(PSAQTY)*$GET(PSADUOU))_" to "_$PIECE($GET(^PSDRUG(PSADRG,0)),"^")
- +17 WRITE !,"Entering new drug selection as an adjustment."
- +18 SET PSAREA=""
- SET PSADJFLD="D"
- SET PSADJ=PSADRG
- DO RECORD^PSAVER2
- +19 DO 50^PSAVER7
- FILE ;File dispense units per order units into 58.811
- +1 SET DIE="^PSD(58.811,"_PSAIEN_",1,"_PSAIEN1_",1,"
- +2 SET DA=PSALINE
- SET DA(1)=PSAIEN1
- SET DA(2)=PSAIEN
- +3 SET DR="10///"_PSADUOU
- +4 DO ^DIE
- +5 ;File data in 58.8
- +6 ;PSALOC= Either PSALOC or PSALOCB
- +7 ;VMP OIFO BAY PINES;VGF;PSA*3.0*40;UPDATE
- +8 SET PSADRG=PSABEFOR
- +9 FOR
- LOCK +^PSD(58.8,PSALOC,1,PSADRG,0):0
- IF $TEST
- QUIT
- +10 SET PSADUREC=PSAQTY*$GET(PSAODUOU)
- +11 SET PSABAL=$PIECE($GET(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",4)
- +12 SET $PIECE(^PSD(58.8,PSALOC,1,PSADRG,0),"^",4)=PSABAL-PSADUREC
- +13 LOCK -^PSD(58.8,PSALOC,1,PSADRG,0)
- +14 ;VMP OIFO BAY PINES;VGF;PSA*3.0*40;ADDED *$G(PSADUOU)
- +15 SET PSADRG=PSAAFTER
- +16 SET PSADUREC=PSAQTY*$GET(PSADUOU)
- +17 DO NOW^%DTC
- SET PSADT=+$EXTRACT(%,1,14)
- +18 IF '$DATA(^PSD(58.8,PSALOC,1,PSADRG,0))
- Begin DoDot:1
- +19 IF '$DATA(^PSD(58.8,PSALOC,1,0))
- SET DIC("P")=$PIECE(^DD(58.8,10,0),"^",2)
- +20 ;*53
- SET DA(1)=PSALOC
- SET DIC="^PSD(58.8,"_DA(1)_",1,"
- SET (DA,DINUM,X)=PSADRG
- SET DIC(0)="L"
- SET DLAYGO=58.8
- +21 FOR
- LOCK +^PSD(58.8,PSALOC,0):0
- IF $TEST
- QUIT
- +22 DO FILE^DICN
- LOCK -^PSD(58.8,PSALOC,0)
- KILL DIC,DA,DLAYGO
- End DoDot:1
- +23 FOR
- LOCK +^PSD(58.8,PSALOC,1,PSADRG,0):0
- IF $TEST
- QUIT
- +24 SET PSABAL=$PIECE($GET(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",4)
- +25 IF $PIECE($GET(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",1)'=PSADRG
- SET $PIECE(^PSD(58.8,PSALOC,1,PSADRG,0),"^",1)=PSADRG
- +26 SET $PIECE(^PSD(58.8,PSALOC,1,PSADRG,0),"^",4)=PSADUREC+PSABAL
- +27 IF +$PIECE($GET(^PSD(58.8,PSALOC,0)),"^",14)
- Begin DoDot:1
- +28 IF PSASTOCK'=$PIECE(^PSD(58.8,PSALOC,1,PSADRG,0),"^",3)
- SET $PIECE(^PSD(58.8,PSALOC,1,PSADRG,0),"^",3)=PSASTOCK
- +29 IF PSAREORD'=$PIECE(^PSD(58.8,PSALOC,1,PSADRG,0),"^",5)
- SET $PIECE(^PSD(58.8,PSALOC,1,PSADRG,0),"^",5)=PSAREORD
- End DoDot:1
- +30 IF '$DATA(^PSD(58.8,PSALOC,1,PSADRG,5,0))
- SET DIC("P")=$PIECE(^DD(58.8001,20,0),"^",2)
- +31 IF '$DATA(^PSD(58.8,PSALOC,1,PSADRG,5,$EXTRACT(DT,1,5)*100,0))
- Begin DoDot:1
- +32 SET DIC="^PSD(58.8,"_PSALOC_",1,"_PSADRG_",5,"
- SET DIC(0)="L"
- SET DIC("DR")="1////^S X=$G(PSABAL)"
- SET (X,DINUM)=$EXTRACT(DT,1,5)*100
- SET DA(2)=PSALOC
- SET DA(1)=PSADRG
- SET DLAYGO=58.8
- DO ^DIC
- KILL DIC
- +33 SET X="T-1M"
- DO ^%DT
- SET DIC="^PSD(58.8,"_PSALOC_",1,"_PSADRG_",5,"
- SET DIC(0)="L"
- SET (X,DINUM)=$EXTRACT(Y,1,5)*100
- DO ^DIC
- KILL DIC,DLAYGO
- SET DA=+Y
- +34 SET DA(2)=PSALOC
- SET DA(1)=PSADRG
- SET DIE="^PSD(58.8,"_DA(2)_",1,"_DA(1)_",5,"
- SET DR="3////^S X=$G(PSABAL)"
- DO ^DIE
- KILL DIE
- End DoDot:1
- +35 SET DA(2)=PSALOC
- SET DA(1)=PSADRG
- SET DIE="^PSD(58.8,"_DA(2)_",1,"_DA(1)_",5,"
- SET DA=$EXTRACT(DT,1,5)*100
- SET DR="5////^S X="_($PIECE($GET(^(0)),"^",3)+PSADUREC)
- DO ^DIE
- KILL DIE
- +36 LOCK -^PSD(58.8,PSALOC,1,PSADRG,0)
- +37 WRITE !,"updating pharmacy location file."
- FILE581 ;Update transaction file
- +1 SET PSAVDUZ=DUZ
- 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)>0
- SET DR=DR_";100////^S X=PSACS"
- +4 FOR
- LOCK +^PSD(58.81,DA,0):0
- IF $TEST
- QUIT
- +5 DO ^DIE
- LOCK -^PSD(58.81,DA,0)
- KILL DIE
- WRITE !,"updating transaction file."
- QUIT
- +6 ;
- HDR WRITE @IOF,!?25,"EDIT VERIFIED INVOICED ITEM SCREEN",!,PSASLN,!
- +1 WRITE !,?44,"Order",!,"#",?10,"Drug/Item Name",?45,"Unit",?56,"Qnty.",?67,"NDC",!,PSASLN,!
- QUIT
- Q KILL AN,D,DA,DATA,DIC,DIR,INVARRAY,LINENUM,PSA50IEN,PSABAL,PSABEFOR,PSACS,PSADATA,PSADJ,PSADJFLD,PSADRG,PSADT,PSADUREC,PSAGAIN,PSAIEN,PSAIEN1,PSAIN,PSAINV,PSALINE,PSALINEN
- +1 KILL PSALOC,PSANDC,PSAORD,PSAOUT,PSAQTY,PSAREA,PSAREORD,PSASLN,PSASTOCK,PSASUB,PSASUP,PSASUPP,PSAT,PSAVER,X,X1,X2,X3,XX,XXX,Y,PSAODUOU
- +2 KILL PSAODU,PSAODUOU,PSAXDUOU
- +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