- PSAVERA1 ;BHM/DB - Edit previously verified invoices;16NOV99
- ;;3.0;DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**21,61,63,70,71,80,81**;Oct 24,1997;Build 10
- ;References to ^DIC(51.5 are covered by IA #1931
- ;References to ^PSDRUG( are covered by IA #2095
- ;
- S $P(PSASLN,"=",79)="" K PSALINE
- DISPLN S PSALINE=$S('$D(PSALINE):$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,0)),1:$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE))) G Q:PSALINE'>0 S CNT=$G(CNT)+1
- S PSADATA=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,0))
- S PSATEMP=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,2))
- S PSAVSN=$P(PSADATA,"^",12),PSAOUT=0,PSADRUGN=""
- DRUG S PSADJ=+$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","D",0))
- I $G(PSADJ) D
- .S PSANODE=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ,0))
- .S PSADJD=$S($P(PSANODE,"^",6)'="":$P(PSANODE,"^",6),1:$P(PSANODE,"^",2))
- .S PSASUP=$S(PSADJD'?1.N:1,1:0)
- .S PSADRG=$S(PSADJ&('PSASUP):$G(PSADJD),PSADJ&(PSASUP):0,1:+$P(PSADATA,"^",2))
- .I $G(PSADJD),$L(PSADJD)=$L(+PSADJD),$P($G(^PSDRUG(+PSADJD,0)),"^")'="" S (PSADRG,PSA50IEN)=+PSADJD Q
- .I $G(PSADJD),$L(PSADJD)=$L(+PSADJD),$P($G(^PSDRUG(+PSADJD,0)),"^")="" S (PSADJ,PSADRG)=0 Q
- .S PSADJSUP=1,(PSADRG,PSA50IEN)=PSADJD
- I '$G(PSADJ) D
- .S (PSA50IEN,PSADRG)=$S(+$P(PSADATA,"^",2)&($P($G(^PSDRUG(+$P(PSADATA,"^",2),0)),"^")'=""):+$P(PSADATA,"^",2),1:0)
- I $G(PSASUP) S PSADRUGN=PSADRG_" - SUP/ITM" ;;<- PSA*3*70 RJS
- S:'$G(PSADRUGN) PSADRUGN=$S($P($G(^PSDRUG(PSADRG,0)),"^")'="":$P($G(^PSDRUG(PSADRG,0)),"^"),1:"Unknown Drug Name/Supply Item")
- QTY ;Quantity
- ;No Adj. Qty
- S PSADJQ="",PSADJ=+$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","Q",0))
- I $G(PSADJ) S PSANODE=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ,0)),PSADJQ=$S($P(PSANODE,"^",6)'="":+$P(PSANODE,"^",6),1:$P(PSANODE,"^",2))
- ;Adj. Qty
- I $G(PSADJQ) S PSAQTY=PSADJQ
- I '$G(PSADJQ) S PSAQTY=$P(PSADATA,"^",3)
- UPC S:$P(PSADATA,"^",13) PSAUPC=$P(PSADATA,"^",13)
- OU ;W !,"Order Unit : "
- S PSAOU=$S(+$P(PSADATA,"^",4)&($P($G(^DIC(51.5,+$P(PSADATA,"^",4),0)),"^")'=""):+$P(PSADATA,"^",4),1:"")
- S PSATEMP=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,2))
- I +$P(PSATEMP,"^",3),PSADRG,+$P($G(^PSDRUG(PSADRG,1,+$P(PSATEMP,"^",3),0)),"^",5) S PSAOU=+$P(^PSDRUG(PSADRG,1,+$P(PSATEMP,"^",3),0),"^",5)
- S PSADJO="",PSADJ=+$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","O",0))
- I $G(PSADJ) S PSANODE=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ,0)),PSADJO=$S($P(PSANODE,"^",6)'="":$P(PSANODE,"^",6),1:$P(PSANODE,"^",2))
- ;Adj. Order Unit
- I PSADJO'="" S PSAOU=+PSADJO
- I PSADJO="" ;W $S(+PSAOU:$P($G(^DIC(51.5,+PSAOU,0)),"^"),1:"Blank")
- ;
- NDC S PSANDC=$P(PSADATA,"^",11)
- ;I $E(PSANDC)'="S" W ?38,"NDC: "_$S(PSANDC'="":$E(PSANDC,1,6)_"-"_$E(PSANDC,7,10)_"-"_$E(PSANDC,11,12),1:"Blank")
- ;
- PRICE ;W !,"Unit Price : $"
- S PSADJP=0,PSADJ=+$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","P",0))
- I $G(PSADJ) S PSANODE=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ,0)),PSADJP=$S(+$P(PSANODE,"^",6):+$P(PSANODE,"^",6),1:+$P(PSANODE,"^",2))
- ;Adj. Unit Price
- I $G(PSADJP) D
- .I $L($P(PSADJP,".",2))<2 S PSADJP=$P(PSADJP,".")_"."_$P(PSADJP,".",2)_$E("00",1,(2-$L($P(PSADJP,".",2))))
- .;W $FN(PSADJP,",")_" ($"_$S(+$P(PSADATA,"^",5):$FN($P(PSADATA,"^",5),","),$P(PSADATA,"^",5)=0:"0.00",1:"")_")"
- .S PSAPRICE=PSADJP
- I '$G(PSADJP) D
- .S PSAPRICE=+$P(PSADATA,"^",5)
- .;I $G(PSAPRICE)!(PSAPRICE=0) W $S($G(PSAPRICE):PSAPRICE,1:"0.00") Q
- .;W "Blank"
- ;
- VSN ;W ?38,"VSN: "_$S(PSAVSN'="":PSAVSN,1:"Blank"),!
- VDU S PSADUOU=+$P(PSATEMP,"^"),PSAREORD=+$P(PSATEMP,"^",2),PSASUB=+$P(PSATEMP,"^",3),PSASTOCK=+$P(PSATEMP,"^",4)
- S INVARRAY(PSAORD,PSAINV,PSALINE)=$G(PSADRG)_"~"_$G(PSADRUGN)_"^"_$G(PSAQTY)_"^"_$G(PSALOC)_"^"_$G(PSAOU)_"^"_$G(PSANDC)_"^"_$G(PSAPRICE)_"^"_$G(PSAVSN)_"^"_$G(PSAUPC),PSASUP=0
- ;
- I '+$P($G(^PSD(58.8,+PSALOC,0)),"^",14) G DISPLN
- ;
- STOCK S PSASTOCK=$S(+PSASTOCK:+PSASTOCK,+$P($G(^PSD(58.8,+PSALOC,1,+PSADRG,0)),"^",3):+$P($G(^PSD(58.8,+PSALOC,1,+PSADRG,0)),"^",3),1:"Blank")
- REORDER S PSAREORD=$S(+PSAREORD:+PSAREORD,+$P($G(^PSD(58.8,+PSALOC,1,+PSADRG,0)),"^",5):+$P($G(^PSD(58.8,+PSALOC,1,+PSADRG,0)),"^",5),1:"Blank")
- S INVARRAY(PSAORD,PSAINV,PSALINE)=$G(INVARRAY(PSAORD,PSAINV,PSALINE))_"^"_$G(PSASTOCK)_"^"_$G(PSAREORD)
- G DISPLN
- ASK R !!,"Enter an '^' to abort, <RET> to continue, or a corresponding line item number: ",AN:DTIME I AN="" G DISPLN
- I AN["^" G Q
- I AN<0!(AN>CNT) W !,"Enter a number between 1 and ",CNT G ASK
- S (PSALINE,PSALINEN)=AN
- PROCSS I '$D(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,0)) W !,"Invalid line number." G ASK
- S PSADATA=^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,0),PSASUP=0
- S PSANDC=$P(PSADATA,"^",11),PSAVSN=$P(PSADATA,"^",12),PSALOC=$S($P(PSADATA,"^",10):+$P(PSAIN,"^",12),1:+$P(PSAIN,"^",5))
- VIEW S PSALINEN=" " D VERDISP^PSAUTL4 W !,PSASLN,!
- W "1. Drug",!,"2. Order Unit",! S PSACHO=2
- S DIR(0)="LO^1:"_PSACHO,DIR("A")="Edit fields",DIR("?")="Enter the number(s) of the data to be edited" S DIR("??")="^D DDQOR^PSAVER3"
- D ^DIR K DIR I $G(DTOUT)!($G(DUOUT)) S PSAOUT=1 Q
- Q:Y="" S PSAFLDS=Y,PSASET=0 ;D VERDISP^PSAUTL4 W PSASLN
- FIELDS F PSAPCF=1:1 S PSAFLD=$P(PSAFLDS,",",PSAPCF) Q:'PSAFLD!(PSAOUT) D
- .I PSAFLD=1 D ASKDRUG^PSAVERA2 Q
- .I PSAFLD=2 D OU^PSAVER2 Q
- Q Q
- ;
- UPDATE ; *63 RJS CODE REMOVED FROM PSAVERA AND CALLED BY PSAVERA
- ;File data in 58.8
- ;PSALOC = Either PSALOCA or PSALOCB
- N PSALOCA,PSALOCB ;p81
- S PSADRG=PSABFR,PSABAL=0 I $D(^PSDRUG(PSADRG,0)) D LOCCHK S PSALOC=PSALOCB D ;p81
- .F L +^PSD(58.8,PSALOC,1,PSADRG,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
- .S PSADUREC=PSAQTY*$G(PSAODUOU),PSABAL=$P($G(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",4),$P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",4)=PSABAL-$G(PSABFR("Q"))
- .L -^PSD(58.8,PSALOC,1,PSADRG,0)
- S PSADRG=PSAAFTER,PSAABAL=PSABAL,PSADUREC=PSAQTY*$G(PSADUOU) D LOCCHK S PSALOC=PSALOCA
- 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):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
- .D FILE^DICN L -^PSD(58.8,PSALOC,0) K DIC,DA,DLAYGO
- F L +^PSD(58.8,PSALOC,1,PSADRG,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) 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 ;;*63
- S PSAVDUZ=DUZ,PSAREA="EDIT VERIFIED INVOICE"
- I '$G(PSABFR(581)) D NEW581 Q
- ;I PSADRG'=PSABFR S PSANQTY=0,PSAAQTY=$G(PSABFR("Q"))*-1,PSALOC=PSALOCB ;<*75 RJS
- ;I PSADRG=PSABFR S PSANQTY=PSADUREC D
- ;.S PSAAQTY=PSADUREC-$G(PSABFR("Q"))
- 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
- ;
- N PSAPVLT,PSAMVLT,PSACLOC,PSANEWL ;p81
- S PSAPVLT=0,PSAMVLT=0,PSANEWL=0
- S PSAPVLT=$P($G(PSALIDAT),"^",5),PSAMVLT=$P($G(PSALIDAT),"^",12) ; Primary and Master vaults
- S PSACLOC=$P($G(PSABFR("581")),"^",3) ; The current vault
- I $P($G(^PSDRUG(PSADRG,2)),"^",3)["N",PSACLOC'=PSAMVLT S PSANEWL=PSAMVLT
- I $P($G(^PSDRUG(PSADRG,2)),"^",3)'["N",PSACLOC'=PSAPVLT S PSANEWL=PSAPVLT
- ;
- I PSADRG'=PSABFR S PSANQTY=0,PSAAQTY=$G(PSABFR("Q"))*-1,PSALOC=PSALOCB ;<*75 RJS
- I PSADRG=PSABFR S PSANQTY=PSADUREC D
- .I PSANEWL S PSAAQTY=$G(PSABFR("Q"))*-1,PSALOC=PSACLOC Q ;p81
- .S PSAAQTY=PSADUREC-$G(PSABFR("Q"))
- I PSAAFTER'=PSABFR S PSADRG=PSABFR
- S DR="1////14;2////^S X=PSALOC;3////^S X=PSADT;4////^S X=PSADRG;48////^S X=PSADT;49////^S X=PSAVDUZ;50////^S X=PSANQTY;51////^S X=PSAAQTY;53////^S X=PSAREA;54////^S X=PSAABAL;71////^S X=PSAINV;106////^S X=PSAORD"
- F L +^PSD(58.81,DA,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
- D ^DIE L -^PSD(58.81,DA,0) K DIE
- I PSAAFTER'=PSABFR S PSADRG=PSAAFTER,PSALOC=PSALOCA D NEW581 Q ;p81
- I $G(PSANEWL) S PSALOC=PSANEWL D NEW581 ;p81
- Q
- ;
- NEW581 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 NEW581
- 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 PSADUREC=PSAQTY*$G(PSADUOU)
- 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):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
- D ^DIE L -^PSD(58.81,DA,0) K DIE W !,"updating transaction file." Q
- Q
- LOCCHK ; Update Line items with CS or Non-CS
- S:$D(PSABFR(581)) PSALOCB=$P(PSABFR(581),"^",3)
- S PSACS=$P(^PSD(58.811,PSAIEN,1,PSAIEN1,0),"^",8)
- I $P($G(^PSDRUG(PSAAFTER,2)),"^",3)["N" D
- . I '$P(PSADATA,"^",10) D
- . . S DIE="^PSD(58.811,"_PSAIEN_",1,"_PSAIEN1_",1,",DA=PSALINE,DA(1)=PSAIEN1,DA(2)=PSAIEN,DR="12////1" D ^DIE K DA,DIE,DR
- . S PSALOCA=+$G(PSACSLOC)
- I $P($G(^PSDRUG(PSAAFTER,2)),"^",3)'["N" D
- . I $P(PSADATA,"^",10) D
- . . S DIE="^PSD(58.811,"_PSAIEN_",1,"_PSAIEN1_",1,",DA=PSALINE,DA(1)=PSAIEN1,DA(2)=PSAIEN,DR="12////0" D ^DIE K DA,DIE,DR
- . S PSALOCA=PSANCSLO
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSAVERA1 10322 printed Apr 23, 2025@18:05:36 Page 2
- PSAVERA1 ;BHM/DB - Edit previously verified invoices;16NOV99
- +1 ;;3.0;DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**21,61,63,70,71,80,81**;Oct 24,1997;Build 10
- +2 ;References to ^DIC(51.5 are covered by IA #1931
- +3 ;References to ^PSDRUG( are covered by IA #2095
- +4 ;
- +5 SET $PIECE(PSASLN,"=",79)=""
- KILL PSALINE
- DISPLN SET PSALINE=$SELECT('$DATA(PSALINE):$ORDER(^PSD(58.811,PSAIEN,1,PSAIEN1,1,0)),1:$ORDER(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE)))
- if PSALINE'>0
- GOTO Q
- SET CNT=$GET(CNT)+1
- +1 SET PSADATA=$GET(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,0))
- +2 SET PSATEMP=$GET(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,2))
- +3 SET PSAVSN=$PIECE(PSADATA,"^",12)
- SET PSAOUT=0
- SET PSADRUGN=""
- DRUG SET PSADJ=+$ORDER(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","D",0))
- +1 IF $GET(PSADJ)
- Begin DoDot:1
- +2 SET PSANODE=$GET(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ,0))
- +3 SET PSADJD=$SELECT($PIECE(PSANODE,"^",6)'="":$PIECE(PSANODE,"^",6),1:$PIECE(PSANODE,"^",2))
- +4 SET PSASUP=$SELECT(PSADJD'?1.N:1,1:0)
- +5 SET PSADRG=$SELECT(PSADJ&('PSASUP):$GET(PSADJD),PSADJ&(PSASUP):0,1:+$PIECE(PSADATA,"^",2))
- +6 IF $GET(PSADJD)
- IF $LENGTH(PSADJD)=$LENGTH(+PSADJD)
- IF $PIECE($GET(^PSDRUG(+PSADJD,0)),"^")'=""
- SET (PSADRG,PSA50IEN)=+PSADJD
- QUIT
- +7 IF $GET(PSADJD)
- IF $LENGTH(PSADJD)=$LENGTH(+PSADJD)
- IF $PIECE($GET(^PSDRUG(+PSADJD,0)),"^")=""
- SET (PSADJ,PSADRG)=0
- QUIT
- +8 SET PSADJSUP=1
- SET (PSADRG,PSA50IEN)=PSADJD
- End DoDot:1
- +9 IF '$GET(PSADJ)
- Begin DoDot:1
- +10 SET (PSA50IEN,PSADRG)=$SELECT(+$PIECE(PSADATA,"^",2)&($PIECE($GET(^PSDRUG(+$PIECE(PSADATA,"^",2),0)),"^")'=""):+$PIECE(PSADATA,"^",2),1:0)
- End DoDot:1
- +11 ;;<- PSA*3*70 RJS
- IF $GET(PSASUP)
- SET PSADRUGN=PSADRG_" - SUP/ITM"
- +12 if '$GET(PSADRUGN)
- SET PSADRUGN=$SELECT($PIECE($GET(^PSDRUG(PSADRG,0)),"^")'="":$PIECE($GET(^PSDRUG(PSADRG,0)),"^"),1:"Unknown Drug Name/Supply Item")
- QTY ;Quantity
- +1 ;No Adj. Qty
- +2 SET PSADJQ=""
- SET PSADJ=+$ORDER(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","Q",0))
- +3 IF $GET(PSADJ)
- SET PSANODE=$GET(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ,0))
- SET PSADJQ=$SELECT($PIECE(PSANODE,"^",6)'="":+$PIECE(PSANODE,"^",6),1:$PIECE(PSANODE,"^",2))
- +4 ;Adj. Qty
- +5 IF $GET(PSADJQ)
- SET PSAQTY=PSADJQ
- +6 IF '$GET(PSADJQ)
- SET PSAQTY=$PIECE(PSADATA,"^",3)
- UPC if $PIECE(PSADATA,"^",13)
- SET PSAUPC=$PIECE(PSADATA,"^",13)
- OU ;W !,"Order Unit : "
- +1 SET PSAOU=$SELECT(+$PIECE(PSADATA,"^",4)&($PIECE($GET(^DIC(51.5,+$PIECE(PSADATA,"^",4),0)),"^")'=""):+$PIECE(PSADATA,"^",4),1:"")
- +2 SET PSATEMP=$GET(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,2))
- +3 IF +$PIECE(PSATEMP,"^",3)
- IF PSADRG
- IF +$PIECE($GET(^PSDRUG(PSADRG,1,+$PIECE(PSATEMP,"^",3),0)),"^",5)
- SET PSAOU=+$PIECE(^PSDRUG(PSADRG,1,+$PIECE(PSATEMP,"^",3),0),"^",5)
- +4 SET PSADJO=""
- SET PSADJ=+$ORDER(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","O",0))
- +5 IF $GET(PSADJ)
- SET PSANODE=$GET(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ,0))
- SET PSADJO=$SELECT($PIECE(PSANODE,"^",6)'="":$PIECE(PSANODE,"^",6),1:$PIECE(PSANODE,"^",2))
- +6 ;Adj. Order Unit
- +7 IF PSADJO'=""
- SET PSAOU=+PSADJO
- +8 ;W $S(+PSAOU:$P($G(^DIC(51.5,+PSAOU,0)),"^"),1:"Blank")
- IF PSADJO=""
- +9 ;
- NDC SET PSANDC=$PIECE(PSADATA,"^",11)
- +1 ;I $E(PSANDC)'="S" W ?38,"NDC: "_$S(PSANDC'="":$E(PSANDC,1,6)_"-"_$E(PSANDC,7,10)_"-"_$E(PSANDC,11,12),1:"Blank")
- +2 ;
- PRICE ;W !,"Unit Price : $"
- +1 SET PSADJP=0
- SET PSADJ=+$ORDER(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","P",0))
- +2 IF $GET(PSADJ)
- SET PSANODE=$GET(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ,0))
- SET PSADJP=$SELECT(+$PIECE(PSANODE,"^",6):+$PIECE(PSANODE,"^",6),1:+$PIECE(PSANODE,"^",2))
- +3 ;Adj. Unit Price
- +4 IF $GET(PSADJP)
- Begin DoDot:1
- +5 IF $LENGTH($PIECE(PSADJP,".",2))<2
- SET PSADJP=$PIECE(PSADJP,".")_"."_$PIECE(PSADJP,".",2)_$EXTRACT("00",1,(2-$LENGTH($PIECE(PSADJP,".",2))))
- +6 ;W $FN(PSADJP,",")_" ($"_$S(+$P(PSADATA,"^",5):$FN($P(PSADATA,"^",5),","),$P(PSADATA,"^",5)=0:"0.00",1:"")_")"
- +7 SET PSAPRICE=PSADJP
- End DoDot:1
- +8 IF '$GET(PSADJP)
- Begin DoDot:1
- +9 SET PSAPRICE=+$PIECE(PSADATA,"^",5)
- +10 ;I $G(PSAPRICE)!(PSAPRICE=0) W $S($G(PSAPRICE):PSAPRICE,1:"0.00") Q
- +11 ;W "Blank"
- End DoDot:1
- +12 ;
- VSN ;W ?38,"VSN: "_$S(PSAVSN'="":PSAVSN,1:"Blank"),!
- VDU SET PSADUOU=+$PIECE(PSATEMP,"^")
- SET PSAREORD=+$PIECE(PSATEMP,"^",2)
- SET PSASUB=+$PIECE(PSATEMP,"^",3)
- SET PSASTOCK=+$PIECE(PSATEMP,"^",4)
- +1 SET INVARRAY(PSAORD,PSAINV,PSALINE)=$GET(PSADRG)_"~"_$GET(PSADRUGN)_"^"_$GET(PSAQTY)_"^"_$GET(PSALOC)_"^"_$GET(PSAOU)_"^"_$GET(PSANDC)_"^"_$GET(PSAPRICE)_"^"_$GET(PSAVSN)_"^"_$GET(PSAUPC)
- SET PSASUP=0
- +2 ;
- +3 IF '+$PIECE($GET(^PSD(58.8,+PSALOC,0)),"^",14)
- GOTO DISPLN
- +4 ;
- STOCK SET PSASTOCK=$SELECT(+PSASTOCK:+PSASTOCK,+$PIECE($GET(^PSD(58.8,+PSALOC,1,+PSADRG,0)),"^",3):+$PIECE($GET(^PSD(58.8,+PSALOC,1,+PSADRG,0)),"^",3),1:"Blank")
- REORDER SET PSAREORD=$SELECT(+PSAREORD:+PSAREORD,+$PIECE($GET(^PSD(58.8,+PSALOC,1,+PSADRG,0)),"^",5):+$PIECE($GET(^PSD(58.8,+PSALOC,1,+PSADRG,0)),"^",5),1:"Blank")
- +1 SET INVARRAY(PSAORD,PSAINV,PSALINE)=$GET(INVARRAY(PSAORD,PSAINV,PSALINE))_"^"_$GET(PSASTOCK)_"^"_$GET(PSAREORD)
- +2 GOTO DISPLN
- ASK READ !!,"Enter an '^' to abort, <RET> to continue, or a corresponding line item number: ",AN:DTIME
- IF AN=""
- GOTO DISPLN
- +1 IF AN["^"
- GOTO Q
- +2 IF AN<0!(AN>CNT)
- WRITE !,"Enter a number between 1 and ",CNT
- GOTO ASK
- +3 SET (PSALINE,PSALINEN)=AN
- PROCSS IF '$DATA(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,0))
- WRITE !,"Invalid line number."
- GOTO ASK
- +1 SET PSADATA=^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,0)
- SET PSASUP=0
- +2 SET PSANDC=$PIECE(PSADATA,"^",11)
- SET PSAVSN=$PIECE(PSADATA,"^",12)
- SET PSALOC=$SELECT($PIECE(PSADATA,"^",10):+$PIECE(PSAIN,"^",12),1:+$PIECE(PSAIN,"^",5))
- VIEW SET PSALINEN=" "
- DO VERDISP^PSAUTL4
- WRITE !,PSASLN,!
- +1 WRITE "1. Drug",!,"2. Order Unit",!
- SET PSACHO=2
- +2 SET DIR(0)="LO^1:"_PSACHO
- SET DIR("A")="Edit fields"
- SET DIR("?")="Enter the number(s) of the data to be edited"
- SET DIR("??")="^D DDQOR^PSAVER3"
- +3 DO ^DIR
- KILL DIR
- IF $GET(DTOUT)!($GET(DUOUT))
- SET PSAOUT=1
- QUIT
- +4 ;D VERDISP^PSAUTL4 W PSASLN
- if Y=""
- QUIT
- SET PSAFLDS=Y
- SET PSASET=0
- FIELDS FOR PSAPCF=1:1
- SET PSAFLD=$PIECE(PSAFLDS,",",PSAPCF)
- if 'PSAFLD!(PSAOUT)
- QUIT
- Begin DoDot:1
- +1 IF PSAFLD=1
- DO ASKDRUG^PSAVERA2
- QUIT
- +2 IF PSAFLD=2
- DO OU^PSAVER2
- QUIT
- End DoDot:1
- Q QUIT
- +1 ;
- UPDATE ; *63 RJS CODE REMOVED FROM PSAVERA AND CALLED BY PSAVERA
- +1 ;File data in 58.8
- +2 ;PSALOC = Either PSALOCA or PSALOCB
- +3 ;p81
- NEW PSALOCA,PSALOCB
- +4 ;p81
- SET PSADRG=PSABFR
- SET PSABAL=0
- IF $DATA(^PSDRUG(PSADRG,0))
- DO LOCCHK
- SET PSALOC=PSALOCB
- Begin DoDot:1
- +5 FOR
- LOCK +^PSD(58.8,PSALOC,1,PSADRG,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
- IF $TEST
- QUIT
- +6 SET PSADUREC=PSAQTY*$GET(PSAODUOU)
- SET PSABAL=$PIECE($GET(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",4)
- SET $PIECE(^PSD(58.8,PSALOC,1,PSADRG,0),"^",4)=PSABAL-$GET(PSABFR("Q"))
- +7 LOCK -^PSD(58.8,PSALOC,1,PSADRG,0)
- End DoDot:1
- +8 SET PSADRG=PSAAFTER
- SET PSAABAL=PSABAL
- SET PSADUREC=PSAQTY*$GET(PSADUOU)
- DO LOCCHK
- SET PSALOC=PSALOCA
- +9 DO NOW^%DTC
- SET PSADT=+$EXTRACT(%,1,14)
- +10 IF '$DATA(^PSD(58.8,PSALOC,1,PSADRG,0))
- Begin DoDot:1
- +11 if '$DATA(^PSD(58.8,PSALOC,1,0))
- SET DIC("P")=$PIECE(^DD(58.8,10,0),"^",2)
- +12 ;*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
- +13 FOR
- LOCK +^PSD(58.8,PSALOC,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
- IF $TEST
- QUIT
- +14 DO FILE^DICN
- LOCK -^PSD(58.8,PSALOC,0)
- KILL DIC,DA,DLAYGO
- End DoDot:1
- +15 FOR
- LOCK +^PSD(58.8,PSALOC,1,PSADRG,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
- IF $TEST
- QUIT
- +16 SET PSABAL=$PIECE($GET(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",4)
- +17 IF $PIECE($GET(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",1)'=PSADRG
- SET $PIECE(^PSD(58.8,PSALOC,1,PSADRG,0),"^",1)=PSADRG
- +18 SET $PIECE(^PSD(58.8,PSALOC,1,PSADRG,0),"^",4)=PSADUREC+PSABAL
- +19 IF +$PIECE($GET(^PSD(58.8,PSALOC,0)),"^",14)
- Begin DoDot:1
- +20 IF PSASTOCK'=$PIECE(^PSD(58.8,PSALOC,1,PSADRG,0),"^",3)
- SET $PIECE(^PSD(58.8,PSALOC,1,PSADRG,0),"^",3)=PSASTOCK
- +21 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
- +22 if '$DATA(^PSD(58.8,PSALOC,1,PSADRG,5,0))
- SET DIC("P")=$PIECE(^DD(58.8001,20,0),"^",2)
- +23 IF '$DATA(^PSD(58.8,PSALOC,1,PSADRG,5,$EXTRACT(DT,1,5)*100,0))
- Begin DoDot:1
- +24 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
- +25 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
- +26 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
- +27 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
- +28 LOCK -^PSD(58.8,PSALOC,1,PSADRG,0)
- +29 WRITE !,"updating pharmacy location file."
- FILE581 ;Update transaction file ;;*63
- +1 SET PSAVDUZ=DUZ
- SET PSAREA="EDIT VERIFIED INVOICE"
- +2 IF '$GET(PSABFR(581))
- DO NEW581
- QUIT
- +3 ;I PSADRG'=PSABFR S PSANQTY=0,PSAAQTY=$G(PSABFR("Q"))*-1,PSALOC=PSALOCB ;<*75 RJS
- +4 ;I PSADRG=PSABFR S PSANQTY=PSADUREC D
- +5 ;.S PSAAQTY=PSADUREC-$G(PSABFR("Q"))
- 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
- +3 ;
- +4 ;p81
- NEW PSAPVLT,PSAMVLT,PSACLOC,PSANEWL
- +5 SET PSAPVLT=0
- SET PSAMVLT=0
- SET PSANEWL=0
- +6 ; Primary and Master vaults
- SET PSAPVLT=$PIECE($GET(PSALIDAT),"^",5)
- SET PSAMVLT=$PIECE($GET(PSALIDAT),"^",12)
- +7 ; The current vault
- SET PSACLOC=$PIECE($GET(PSABFR("581")),"^",3)
- +8 IF $PIECE($GET(^PSDRUG(PSADRG,2)),"^",3)["N"
- IF PSACLOC'=PSAMVLT
- SET PSANEWL=PSAMVLT
- +9 IF $PIECE($GET(^PSDRUG(PSADRG,2)),"^",3)'["N"
- IF PSACLOC'=PSAPVLT
- SET PSANEWL=PSAPVLT
- +10 ;
- +11 ;<*75 RJS
- IF PSADRG'=PSABFR
- SET PSANQTY=0
- SET PSAAQTY=$GET(PSABFR("Q"))*-1
- SET PSALOC=PSALOCB
- +12 IF PSADRG=PSABFR
- SET PSANQTY=PSADUREC
- Begin DoDot:1
- +13 ;p81
- IF PSANEWL
- SET PSAAQTY=$GET(PSABFR("Q"))*-1
- SET PSALOC=PSACLOC
- QUIT
- +14 SET PSAAQTY=PSADUREC-$GET(PSABFR("Q"))
- End DoDot:1
- +15 IF PSAAFTER'=PSABFR
- SET PSADRG=PSABFR
- +16 SET DR="1////14;2////^S X=PSALOC;3////^S X=PSADT;4////^S X=PSADRG;48////^S X=PSADT;49////^S X=PSAVDUZ;50////^S X=PSANQTY;51////^S X=PSAAQTY;53////^S X=PSAREA;54////^S X=PSAABAL;71////^S X=PSAINV;106////^S X=PSAORD"
- +17 FOR
- LOCK +^PSD(58.81,DA,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
- IF $TEST
- QUIT
- +18 DO ^DIE
- LOCK -^PSD(58.81,DA,0)
- KILL DIE
- +19 ;p81
- IF PSAAFTER'=PSABFR
- SET PSADRG=PSAAFTER
- SET PSALOC=PSALOCA
- DO NEW581
- QUIT
- +20 ;p81
- IF $GET(PSANEWL)
- SET PSALOC=PSANEWL
- DO NEW581
- +21 QUIT
- +22 ;
- NEW581 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 NEW581
- +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 PSADUREC=PSAQTY*$GET(PSADUOU)
- +3 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"
- +4 IF $GET(PSACS)>0
- SET DR=DR_";100////^S X=PSACS"
- +5 FOR
- LOCK +^PSD(58.81,DA,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
- IF $TEST
- QUIT
- +6 DO ^DIE
- LOCK -^PSD(58.81,DA,0)
- KILL DIE
- WRITE !,"updating transaction file."
- QUIT
- +7 QUIT
- LOCCHK ; Update Line items with CS or Non-CS
- +1 if $DATA(PSABFR(581))
- SET PSALOCB=$PIECE(PSABFR(581),"^",3)
- +2 SET PSACS=$PIECE(^PSD(58.811,PSAIEN,1,PSAIEN1,0),"^",8)
- +3 IF $PIECE($GET(^PSDRUG(PSAAFTER,2)),"^",3)["N"
- Begin DoDot:1
- +4 IF '$PIECE(PSADATA,"^",10)
- Begin DoDot:2
- +5 SET DIE="^PSD(58.811,"_PSAIEN_",1,"_PSAIEN1_",1,"
- SET DA=PSALINE
- SET DA(1)=PSAIEN1
- SET DA(2)=PSAIEN
- SET DR="12////1"
- DO ^DIE
- KILL DA,DIE,DR
- End DoDot:2
- +6 SET PSALOCA=+$GET(PSACSLOC)
- End DoDot:1
- +7 IF $PIECE($GET(^PSDRUG(PSAAFTER,2)),"^",3)'["N"
- Begin DoDot:1
- +8 IF $PIECE(PSADATA,"^",10)
- Begin DoDot:2
- +9 SET DIE="^PSD(58.811,"_PSAIEN_",1,"_PSAIEN1_",1,"
- SET DA=PSALINE
- SET DA(1)=PSAIEN1
- SET DA(2)=PSAIEN
- SET DR="12////0"
- DO ^DIE
- KILL DA,DIE,DR
- End DoDot:2
- +10 SET PSALOCA=PSANCSLO
- End DoDot:1
- +11 QUIT
