PSAVERA3 ;BHM/DB - RECORD TRANSACTION & UPDATE DRUG FILE;31JAN00
;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**21,42,70**; 10/24/97;Build 12
;
;References to ^PSDRUG( are covered by IA #2095
;References to ^DIC(51.5 are covered by IA #1931
;
OU S DIC(0)="QAEMZ",DIC="^DIC(51.5,",DIC("A")="Select New Order Unit: "
D ^DIC G Q:+Y'>0 S PSAOU=+Y
I $G(PSAOU)=$G(PSAAOU) W !,"No change." G Q
;;< PSA*3*70
N PSATMPPR
I $G(PSASUP) S (PSATMPPR,DIR("B"))=$S($P($G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,2)),"^",1)'="":$P($G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,2)),"^",1),1:"Blank")
I '$G(PSASUP) S (PSATMPPR,DIR("B"))=$S($P($G(^PSDRUG(PSADRG,660)),"^",5)'="":$P($G(^PSDRUG(PSADRG,660)),"^",5),1:"Blank")
;; PSA*3*70 <
S DIR(0)="NO^::2",DIR("A")="DISPENSE UNITS PER ORDER UNIT"
S DIR("?")="Enter the number of dispense units contained in one order unit",DIR("??")="^D DUOUHELP^PSAPROC3"
D ^DIR K DIR I $G(DTOUT)!($G(DUOUT)) S PSAOUT=1 G Q
S PSANDUOU=+Y
;
DRG K PSASUB S X1=0 F S X1=$O(^PSDRUG(PSADRG,1,X1)) Q:X1'>0 S DATA=$G(^PSDRUG(PSADRG,1,X1,0)) I $P(DATA,"^",1)=PSANDC S PSASUB=X1
;; < PSA*3*70 RJS
W !,"Old Dispense Units Per Order Unit: "
I '$G(PSASUP) W PSATMPPR,?45,"Price Per Disp. Unit: "_$J($P($G(^PSDRUG(PSADRG,660)),"^",6),8,2)
I $G(PSASUP) W PSATMPPR,?45,"Price Per Disp. Unit: " D
.I $G(PSANDUOU),$P($G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,2)),"^") W ($J($P(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,0),"^",5)/$P(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,2),"^"),8,2))
W !,"New Dispense Units Per Order Unit: "_PSANDUOU
I '$G(PSASUP),PSANDUOU=$P($G(^PSDRUG(PSADRG,660)),"^",5) W ?45," unchanged " G UPDATE
I $G(PSASUP),PSANDUOU=$P($G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,2)),"^") W ?45," unchanged " G UPDATE
I $G(PSAPRICE),$G(PSANDUOU) W ?64,$J((PSAPRICE/PSANDUOU),8,2)
;; PSA*3*70 RJS<
UPDATE ;update file
S $P(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,2),"^")=+PSANDUOU S:+PSANDUOU PSASET=1 ;;<PSA*3*70 RJS
I $G(PSANDC)'="",$L(PSANDC)'=11 D
.I $G(PSANDC)'="" S X=11,X1=$L(PSANDC) F X=1:1:(11-X1) S PSANDC="0"_PSANDC ;*42 11 digit NDC
.S NDC0=1 F X=1:1:$L(PSANDC) I $E(PSANDC,X)'=0&($E(PSANDC,X)'="-") K NDC0
.I $G(NDC0)=1 S PSANDC=""
D PSANDC1^PSAHELP S PSADASH=PSANDCX K PSANDCX
;;<PSA*3*70 RJS
I '$G(PSASUP),$P($G(^PSDRUG(PSADRG,2)),"^",4)'=$G(PSADASH) S DIE="^PSDRUG(",DA=PSADRG,DR="31////^S X=PSADASH" D ^DIE
S PSANPDU=0
I $G(PSAPRICE),$G(PSANDUOU) S PSANPDU=PSAPRICE/PSANDUOU
I $G(PSASUP) G SUPITM
;;>PSA*3*70 RJS
W !,"Updating Drug File's Synonym data"
I $G(PSASUB)=""!('$D(^PSDRUG(PSADRG,1))) S DA(1)=PSADRG,DIC="^PSDRUG("_DA(1)_",1,",DIC(0)="L",X=PSANDC,DLAYGO=50 D ^DIC S PSASUB=+Y
S DA(1)=PSADRG,DIE="^PSDRUG("_DA(1)_",1,",DA=PSASUB,DR="401////^S X=PSAOU;403////^S X=PSANDUOU;404////^S X=PSANPDU" D ^DIE
W !,"Updating Drug File's Dispense Units Per Order Unit & Price Per Dispense Unit"
K DR,DIE
S DA=DA(1),DIE="^PSDRUG(",DR="12///^S X=PSAOU;13////^S X=PSAPRICE;15////^S X=PSANDUOU" D ^DIE
SUPITM S PSADJFLD="O",PSADJ=PSAOU,PSAREA="" D RECORD^PSAVER2
W !,"making adjustment in DRUG ACCOUNTABILITY ORDER file"
W !,"TAKING A BREAK !?"
Q
Q Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSAVERA3 3162 printed Nov 22, 2024@17:01:21 Page 2
PSAVERA3 ;BHM/DB - RECORD TRANSACTION & UPDATE DRUG FILE;31JAN00
+1 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**21,42,70**; 10/24/97;Build 12
+2 ;
+3 ;References to ^PSDRUG( are covered by IA #2095
+4 ;References to ^DIC(51.5 are covered by IA #1931
+5 ;
OU SET DIC(0)="QAEMZ"
SET DIC="^DIC(51.5,"
SET DIC("A")="Select New Order Unit: "
+1 DO ^DIC
if +Y'>0
GOTO Q
SET PSAOU=+Y
+2 IF $GET(PSAOU)=$GET(PSAAOU)
WRITE !,"No change."
GOTO Q
+3 ;;< PSA*3*70
+4 NEW PSATMPPR
+5 IF $GET(PSASUP)
SET (PSATMPPR,DIR("B"))=$SELECT($PIECE($GET(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,2)),"^",1)'="":$PIECE($GET(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,2)),"^",1),1:"Blank")
+6 IF '$GET(PSASUP)
SET (PSATMPPR,DIR("B"))=$SELECT($PIECE($GET(^PSDRUG(PSADRG,660)),"^",5)'="":$PIECE($GET(^PSDRUG(PSADRG,660)),"^",5),1:"Blank")
+7 ;; PSA*3*70 <
+8 SET DIR(0)="NO^::2"
SET DIR("A")="DISPENSE UNITS PER ORDER UNIT"
+9 SET DIR("?")="Enter the number of dispense units contained in one order unit"
SET DIR("??")="^D DUOUHELP^PSAPROC3"
+10 DO ^DIR
KILL DIR
IF $GET(DTOUT)!($GET(DUOUT))
SET PSAOUT=1
GOTO Q
+11 SET PSANDUOU=+Y
+12 ;
DRG KILL PSASUB
SET X1=0
FOR
SET X1=$ORDER(^PSDRUG(PSADRG,1,X1))
if X1'>0
QUIT
SET DATA=$GET(^PSDRUG(PSADRG,1,X1,0))
IF $PIECE(DATA,"^",1)=PSANDC
SET PSASUB=X1
+1 ;; < PSA*3*70 RJS
+2 WRITE !,"Old Dispense Units Per Order Unit: "
+3 IF '$GET(PSASUP)
WRITE PSATMPPR,?45,"Price Per Disp. Unit: "_$JUSTIFY($PIECE($GET(^PSDRUG(PSADRG,660)),"^",6),8,2)
+4 IF $GET(PSASUP)
WRITE PSATMPPR,?45,"Price Per Disp. Unit: "
Begin DoDot:1
+5 IF $GET(PSANDUOU)
IF $PIECE($GET(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,2)),"^")
WRITE ($JUSTIFY($PIECE(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,0),"^",5)/$PIECE(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,2),"^"),8,2))
End DoDot:1
+6 WRITE !,"New Dispense Units Per Order Unit: "_PSANDUOU
+7 IF '$GET(PSASUP)
IF PSANDUOU=$PIECE($GET(^PSDRUG(PSADRG,660)),"^",5)
WRITE ?45," unchanged "
GOTO UPDATE
+8 IF $GET(PSASUP)
IF PSANDUOU=$PIECE($GET(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,2)),"^")
WRITE ?45," unchanged "
GOTO UPDATE
+9 IF $GET(PSAPRICE)
IF $GET(PSANDUOU)
WRITE ?64,$JUSTIFY((PSAPRICE/PSANDUOU),8,2)
+10 ;; PSA*3*70 RJS<
UPDATE ;update file
+1 ;;<PSA*3*70 RJS
SET $PIECE(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,2),"^")=+PSANDUOU
if +PSANDUOU
SET PSASET=1
+2 IF $GET(PSANDC)'=""
IF $LENGTH(PSANDC)'=11
Begin DoDot:1
+3 ;*42 11 digit NDC
IF $GET(PSANDC)'=""
SET X=11
SET X1=$LENGTH(PSANDC)
FOR X=1:1:(11-X1)
SET PSANDC="0"_PSANDC
+4 SET NDC0=1
FOR X=1:1:$LENGTH(PSANDC)
IF $EXTRACT(PSANDC,X)'=0&($EXTRACT(PSANDC,X)'="-")
KILL NDC0
+5 IF $GET(NDC0)=1
SET PSANDC=""
End DoDot:1
+6 DO PSANDC1^PSAHELP
SET PSADASH=PSANDCX
KILL PSANDCX
+7 ;;<PSA*3*70 RJS
+8 IF '$GET(PSASUP)
IF $PIECE($GET(^PSDRUG(PSADRG,2)),"^",4)'=$GET(PSADASH)
SET DIE="^PSDRUG("
SET DA=PSADRG
SET DR="31////^S X=PSADASH"
DO ^DIE
+9 SET PSANPDU=0
+10 IF $GET(PSAPRICE)
IF $GET(PSANDUOU)
SET PSANPDU=PSAPRICE/PSANDUOU
+11 IF $GET(PSASUP)
GOTO SUPITM
+12 ;;>PSA*3*70 RJS
+13 WRITE !,"Updating Drug File's Synonym data"
+14 IF $GET(PSASUB)=""!('$DATA(^PSDRUG(PSADRG,1)))
SET DA(1)=PSADRG
SET DIC="^PSDRUG("_DA(1)_",1,"
SET DIC(0)="L"
SET X=PSANDC
SET DLAYGO=50
DO ^DIC
SET PSASUB=+Y
+15 SET DA(1)=PSADRG
SET DIE="^PSDRUG("_DA(1)_",1,"
SET DA=PSASUB
SET DR="401////^S X=PSAOU;403////^S X=PSANDUOU;404////^S X=PSANPDU"
DO ^DIE
+16 WRITE !,"Updating Drug File's Dispense Units Per Order Unit & Price Per Dispense Unit"
+17 KILL DR,DIE
+18 SET DA=DA(1)
SET DIE="^PSDRUG("
SET DR="12///^S X=PSAOU;13////^S X=PSAPRICE;15////^S X=PSANDUOU"
DO ^DIE
SUPITM SET PSADJFLD="O"
SET PSADJ=PSAOU
SET PSAREA=""
DO RECORD^PSAVER2
+1 WRITE !,"making adjustment in DRUG ACCOUNTABILITY ORDER file"
+2 WRITE !,"TAKING A BREAK !?"
+3 QUIT
Q QUIT
