- PSACREDR ;BIR/JMB-Credit Resolution ;7/23/97
- ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3**; 10/24/97
- ;This routine allows the user to apply credit memos to invoices.
- ;
- I '$D(^XUSEC("PSA ORDERS",DUZ)) W !,"You do not hold the key to enter the option." Q
- I '$D(^XUSEC("PSAMGR",DUZ)) W !,"You do not hold the key to enter the option." Q
- I '$O(^PSD(58.811,"AC",1,0)) W !!,"There are no outstanding credit memos." Q
- S PSASLN="",$P(PSASLN,"-",80)=""
- START W ! S DIC="^PSD(58.811,",DIC(0)="AEQM",DIC("S")="I $D(^PSD(58.811,""AC"",1,+Y))" D ^DIC K DIE G:Y<0 EXIT
- G:'$D(^PSD(58.811,+Y,0)) START
- S PSAIEN=+Y,(PSAIEN1,PSAOUT)=0
- F S PSAIEN1=$O(^PSD(58.811,"AC",1,PSAIEN,PSAIEN1)) Q:'PSAIEN1 D
- .Q:'$D(^PSD(58.811,PSAIEN,1,PSAIEN1,0))
- .S (PSACRED,PSAAECST,PSAIECST)=0
- .S PSAIEN2=0 F S PSAIEN2=+$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSAIEN2)) Q:'PSAIEN2!(PSAOUT) D LINE Q:PSAOUT
- .D CREDITS
- D LIST
- G:PSAOUT EXIT G START
- ;
- EXIT ;Kills printing variables only
- K DA,DIC,DIE,DIR,DIRUT,DR,PSA,PSAAECST,PSACIEN,PSACNT,PSACRED,PSADATA,PSADIF,PSADJ,PSADJD,PSADJDA,PSADJP,PSADJQ,PSADJSUP
- K PSAIECST,PSAIEN,PSAIEN1,PSAIEN2,PSAINV,PSALEN,PSAMENU,PSANODE,PSAOUT,PSAPC,PSAPRICE,PSASEL,PSASLN,Y
- Q
- ;
- LINE ;Get line item data
- Q:'$D(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSAIEN2,0))
- K PSADJQ,PSADJP,PSADJD
- S PSADATA=^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSAIEN2,0),PSADJSUP=0
- ;Next line added 4dec97 to bypass checking drug name change
- G DAVE
- DRUG S PSADJ=+$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSAIEN2,1,"B","D",0))
- I $G(PSADJ) D Q:'PSADJSUP
- .S PSANODE=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSAIEN2,1,PSADJ,0))
- .S PSADJD=$S($P(PSANODE,"^",6)'="":$P(PSANODE,"^",6),1:$P(PSANODE,"^",2))
- .Q:$G(PSADJD)&($L(PSADJD)=+$L(PSADJD))
- .S PSADJSUP=1
- DAVE S PSAIECST=PSAIECST+($P(PSADATA,"^",3)*$P(PSADATA,"^",5))
- PRICE S PSADJP=0,PSADJ=+$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSAIEN2,1,"B","P",0))
- I $G(PSADJ) S PSANODE=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSAIEN2,1,PSADJ,0)),PSAPRICE=$S($P(PSANODE,"^",6)'="":$P(PSANODE,"^",6),1:+$P(PSANODE,"^",2))
- I '+PSADJ S PSAPRICE=$P(PSADATA,"^",5)
- QTY S PSADJQ=0,PSADJ=+$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSAIEN2,1,"B","Q",0))
- I $G(PSADJ) S PSANODE=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSAIEN2,1,PSADJ,0)),PSADJQ=$S($P(PSANODE,"^",6)'="":+$P(PSANODE,"^",6),1:$P(PSANODE,"^",2))
- I $G(PSADJQ) S PSAAECST=PSAAECST+(PSADJQ*PSAPRICE)
- I '$G(PSADJQ) S PSAAECST=PSAAECST+($P(PSADATA,"^",3)*PSAPRICE)
- Q
- ;
- CREDITS ;Adds existing credits to adjusted extended cost.
- S PSACIEN=0 F S PSACIEN=$O(^PSD(58.811,PSAIEN,1,PSAIEN1,2,PSACIEN)) Q:'PSACIEN D
- .Q:'$D(^PSD(58.811,PSAIEN,1,PSAIEN1,2,PSACIEN,0))
- .S PSACRED=PSACRED+$P(^PSD(58.811,PSAIEN,1,PSAIEN1,2,PSACIEN,0),"^",3)
- S:PSAAECST'=PSAIECST PSA(PSAIEN1)=PSAIECST_"^"_$J(PSAAECST,$L($P(PSAAECST,".")),2)_"^"_PSACRED
- Q
- ;
- LIST ;Displays the invoices with outstanding credits
- W @IOF,!,"Order#: "_$P($G(^PSD(58.811,PSAIEN,0)),"^")
- W !?28,"Invoice",?42,"Adjusted",?56,"Received",!?4,"Invoice#",?31,"Cost",?46,"Cost",?57,"Credits",?69,"Difference",!,PSASLN
- S (PSACNT,PSAIEN1)=0 F S PSAIEN1=+$O(PSA(PSAIEN1)) Q:'PSAIEN1 D
- .S PSAIECST=+$P(PSA(PSAIEN1),"^"),PSAAECST=+$P(PSA(PSAIEN1),"^",2),PSACRED=+$P(PSA(PSAIEN1),"^",3)
- .S PSACNT=PSACNT+1,PSAMENU(PSACNT,PSAIEN1)=PSA(PSAIEN1)
- .W !,($J(PSACNT,2)),".",?4,$P($G(^PSD(58.811,PSAIEN,1,PSAIEN1,0)),"^"),?26,$J(PSAIECST,9,2),?41,$J(PSAAECST,9,2)
- .W ?55,$J(PSACRED,9,2)
- .S PSADIF=PSAIECST-(PSAAECST+PSACRED)
- .W ?70,$J(PSADIF,9,2)
- I PSACNT'>0 W !!!,?10,"NO INVOICES ON THIS ORDER # FOR CREDITING PURPOSES",! Q ;Dave Blocker 3Dec97
- W ! K DIR S DIR(0)="LO^1:"_PSACNT,DIR("A")="Select invoices",DIR("?")="Select the invoices to which you want to apply credit memos.",DIR("??")="^D CREDHELP^PSACREDR"
- D ^DIR K DIR Q:Y="" I $G(DIRUT) S PSAOUT=1 Q
- S PSASEL=Y
- ;
- SELECT ;Selects invoices for credit memos
- F PSAPC=1:1 S PSACNT=+$P(PSASEL,",",PSAPC) Q:'PSACNT D Q:PSAOUT
- .S PSAINV=$O(PSAMENU(PSACNT,0)),PSAIECST=$P(PSAMENU(PSACNT,PSAINV),"^"),PSAAECST=$P(PSAMENU(PSACNT,PSAINV),"^",2),PSACRED=$P(PSAMENU(PSACNT,PSAINV),"^",3)
- .W !!,"Invoice: "_$P($G(^PSD(58.811,PSAIEN,1,PSAINV,0)),"^"),!
- .S DA(2)=PSAIEN,DA(1)=PSAINV,DA=PSAIEN2
- .S:'$D(^PSD(58.811,PSAIEN,1,PSAINV,2,0)) DIC("P")=$P(^DD(58.8112,6,0),"^",2)
- .S DIC="^PSD(58.811,"_DA(2)_",1,"_DA(1)_",2,",DIC(0)="AEMQL",DIC("A")="CREDIT MEMO: ",DR=.01,DLAYGO=58.811
- .F L +^PSD(58.811,PSAIEN,1,PSAINV,2,0):0 I Q
- .D ^DIC K DLAYGO I Y<0 S PSAOUT=1 K DIC Q
- .S DIE=DIC,DR="1;2;3",(PSADJDA,DA)=+Y D ^DIE K DA,DIE,DIC L -^PSD(58.811,PSAIEN,1,PSAINV,2,0)
- .S PSACRED=PSACRED+$P($G(^PSD(58.811,PSAIEN,1,PSAINV,2,PSADJDA,0)),"^",3)
- .I PSAIECST=$J((PSAAECST+PSACRED),2) S DA(1)=PSAIEN,DA=PSAINV,DIE="^PSD(58.811,"_DA(1)_",1,",DR="10////0" D ^DIE K DIE
- .W !!,"Invoice: "_$P($G(^PSD(58.811,PSAIEN,1,PSAINV,0)),"^") S PSALEN=$L($P($G(^PSD(58.811,PSAIEN,1,PSAINV,0)),"^"))+11
- .W ?PSALEN,"Total Invoiced Cost: "_$J(PSAIECST,9,2),!?PSALEN,"Total Adjusted Cost: "_$J(PSAAECST,9,2)
- .W !?PSALEN,"Total Credits : "_$J(PSACRED,9,2)
- .W !?PSALEN,"Difference : "_$J((PSAIECST-(PSAAECST+PSACRED)),9,2),!
- Q
- ;
- CREDHELP ;Extended help to 'Select invoices'
- W !?5,"Enter the numbers to the left of the invoices for which you want to",!?5,"enter credit memos. To select more than one invoice number, enter"
- W !?5,"the numbers to the left of the invoices separated by a comma or a dash.",!!?5,"For example: Enter 1,2,3,5 or 1-3,5"
- Q
- PSACREDR ;BIR/JMB-Credit Resolution ;7/23/97
- +1 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3**; 10/24/97
- +2 ;This routine allows the user to apply credit memos to invoices.
- +3 ;
- +4 IF '$DATA(^XUSEC("PSA ORDERS",DUZ))
- WRITE !,"You do not hold the key to enter the option."
- QUIT
- +5 IF '$DATA(^XUSEC("PSAMGR",DUZ))
- WRITE !,"You do not hold the key to enter the option."
- QUIT
- +6 IF '$ORDER(^PSD(58.811,"AC",1,0))
- WRITE !!,"There are no outstanding credit memos."
- QUIT
- +7 SET PSASLN=""
- SET $PIECE(PSASLN,"-",80)=""
- START WRITE !
- SET DIC="^PSD(58.811,"
- SET DIC(0)="AEQM"
- SET DIC("S")="I $D(^PSD(58.811,""AC"",1,+Y))"
- DO ^DIC
- KILL DIE
- IF Y<0
- GOTO EXIT
- +1 IF '$DATA(^PSD(58.811,+Y,0))
- GOTO START
- +2 SET PSAIEN=+Y
- SET (PSAIEN1,PSAOUT)=0
- +3 FOR
- SET PSAIEN1=$ORDER(^PSD(58.811,"AC",1,PSAIEN,PSAIEN1))
- IF 'PSAIEN1
- QUIT
- Begin DoDot:1
- +4 IF '$DATA(^PSD(58.811,PSAIEN,1,PSAIEN1,0))
- QUIT
- +5 SET (PSACRED,PSAAECST,PSAIECST)=0
- +6 SET PSAIEN2=0
- FOR
- SET PSAIEN2=+$ORDER(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSAIEN2))
- IF 'PSAIEN2!(PSAOUT)
- QUIT
- DO LINE
- IF PSAOUT
- QUIT
- +7 DO CREDITS
- End DoDot:1
- +8 DO LIST
- +9 IF PSAOUT
- GOTO EXIT
- GOTO START
- +10 ;
- EXIT ;Kills printing variables only
- +1 KILL DA,DIC,DIE,DIR,DIRUT,DR,PSA,PSAAECST,PSACIEN,PSACNT,PSACRED,PSADATA,PSADIF,PSADJ,PSADJD,PSADJDA,PSADJP,PSADJQ,PSADJSUP
- +2 KILL PSAIECST,PSAIEN,PSAIEN1,PSAIEN2,PSAINV,PSALEN,PSAMENU,PSANODE,PSAOUT,PSAPC,PSAPRICE,PSASEL,PSASLN,Y
- +3 QUIT
- +4 ;
- LINE ;Get line item data
- +1 IF '$DATA(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSAIEN2,0))
- QUIT
- +2 KILL PSADJQ,PSADJP,PSADJD
- +3 SET PSADATA=^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSAIEN2,0)
- SET PSADJSUP=0
- +4 ;Next line added 4dec97 to bypass checking drug name change
- +5 GOTO DAVE
- DRUG SET PSADJ=+$ORDER(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSAIEN2,1,"B","D",0))
- +1 IF $GET(PSADJ)
- Begin DoDot:1
- +2 SET PSANODE=$GET(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSAIEN2,1,PSADJ,0))
- +3 SET PSADJD=$SELECT($PIECE(PSANODE,"^",6)'="":$PIECE(PSANODE,"^",6),1:$PIECE(PSANODE,"^",2))
- +4 IF $GET(PSADJD)&($LENGTH(PSADJD)=+$LENGTH(PSADJD))
- QUIT
- +5 SET PSADJSUP=1
- End DoDot:1
- IF 'PSADJSUP
- QUIT
- DAVE SET PSAIECST=PSAIECST+($PIECE(PSADATA,"^",3)*$PIECE(PSADATA,"^",5))
- PRICE SET PSADJP=0
- SET PSADJ=+$ORDER(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSAIEN2,1,"B","P",0))
- +1 IF $GET(PSADJ)
- SET PSANODE=$GET(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSAIEN2,1,PSADJ,0))
- SET PSAPRICE=$SELECT($PIECE(PSANODE,"^",6)'="":$PIECE(PSANODE,"^",6),1:+$PIECE(PSANODE,"^",2))
- +2 IF '+PSADJ
- SET PSAPRICE=$PIECE(PSADATA,"^",5)
- QTY SET PSADJQ=0
- SET PSADJ=+$ORDER(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSAIEN2,1,"B","Q",0))
- +1 IF $GET(PSADJ)
- SET PSANODE=$GET(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSAIEN2,1,PSADJ,0))
- SET PSADJQ=$SELECT($PIECE(PSANODE,"^",6)'="":+$PIECE(PSANODE,"^",6),1:$PIECE(PSANODE,"^",2))
- +2 IF $GET(PSADJQ)
- SET PSAAECST=PSAAECST+(PSADJQ*PSAPRICE)
- +3 IF '$GET(PSADJQ)
- SET PSAAECST=PSAAECST+($PIECE(PSADATA,"^",3)*PSAPRICE)
- +4 QUIT
- +5 ;
- CREDITS ;Adds existing credits to adjusted extended cost.
- +1 SET PSACIEN=0
- FOR
- SET PSACIEN=$ORDER(^PSD(58.811,PSAIEN,1,PSAIEN1,2,PSACIEN))
- IF 'PSACIEN
- QUIT
- Begin DoDot:1
- +2 IF '$DATA(^PSD(58.811,PSAIEN,1,PSAIEN1,2,PSACIEN,0))
- QUIT
- +3 SET PSACRED=PSACRED+$PIECE(^PSD(58.811,PSAIEN,1,PSAIEN1,2,PSACIEN,0),"^",3)
- End DoDot:1
- +4 IF PSAAECST'=PSAIECST
- SET PSA(PSAIEN1)=PSAIECST_"^"_$JUSTIFY(PSAAECST,$LENGTH($PIECE(PSAAECST,".")),2)_"^"_PSACRED
- +5 QUIT
- +6 ;
- LIST ;Displays the invoices with outstanding credits
- +1 WRITE @IOF,!,"Order#: "_$PIECE($GET(^PSD(58.811,PSAIEN,0)),"^")
- +2 WRITE !?28,"Invoice",?42,"Adjusted",?56,"Received",!?4,"Invoice#",?31,"Cost",?46,"Cost",?57,"Credits",?69,"Difference",!,PSASLN
- +3 SET (PSACNT,PSAIEN1)=0
- FOR
- SET PSAIEN1=+$ORDER(PSA(PSAIEN1))
- IF 'PSAIEN1
- QUIT
- Begin DoDot:1
- +4 SET PSAIECST=+$PIECE(PSA(PSAIEN1),"^")
- SET PSAAECST=+$PIECE(PSA(PSAIEN1),"^",2)
- SET PSACRED=+$PIECE(PSA(PSAIEN1),"^",3)
- +5 SET PSACNT=PSACNT+1
- SET PSAMENU(PSACNT,PSAIEN1)=PSA(PSAIEN1)
- +6 WRITE !,($JUSTIFY(PSACNT,2)),".",?4,$PIECE($GET(^PSD(58.811,PSAIEN,1,PSAIEN1,0)),"^"),?26,$JUSTIFY(PSAIECST,9,2),?41,$JUSTIFY(PSAAECST,9,2)
- +7 WRITE ?55,$JUSTIFY(PSACRED,9,2)
- +8 SET PSADIF=PSAIECST-(PSAAECST+PSACRED)
- +9 WRITE ?70,$JUSTIFY(PSADIF,9,2)
- End DoDot:1
- +10 ;Dave Blocker 3Dec97
- IF PSACNT'>0
- WRITE !!!,?10,"NO INVOICES ON THIS ORDER # FOR CREDITING PURPOSES",!
- QUIT
- +11 WRITE !
- KILL DIR
- SET DIR(0)="LO^1:"_PSACNT
- SET DIR("A")="Select invoices"
- SET DIR("?")="Select the invoices to which you want to apply credit memos."
- SET DIR("??")="^D CREDHELP^PSACREDR"
- +12 DO ^DIR
- KILL DIR
- IF Y=""
- QUIT
- IF $GET(DIRUT)
- SET PSAOUT=1
- QUIT
- +13 SET PSASEL=Y
- +14 ;
- SELECT ;Selects invoices for credit memos
- +1 FOR PSAPC=1:1
- SET PSACNT=+$PIECE(PSASEL,",",PSAPC)
- IF 'PSACNT
- QUIT
- Begin DoDot:1
- +2 SET PSAINV=$ORDER(PSAMENU(PSACNT,0))
- SET PSAIECST=$PIECE(PSAMENU(PSACNT,PSAINV),"^")
- SET PSAAECST=$PIECE(PSAMENU(PSACNT,PSAINV),"^",2)
- SET PSACRED=$PIECE(PSAMENU(PSACNT,PSAINV),"^",3)
- +3 WRITE !!,"Invoice: "_$PIECE($GET(^PSD(58.811,PSAIEN,1,PSAINV,0)),"^"),!
- +4 SET DA(2)=PSAIEN
- SET DA(1)=PSAINV
- SET DA=PSAIEN2
- +5 IF '$DATA(^PSD(58.811,PSAIEN,1,PSAINV,2,0))
- SET DIC("P")=$PIECE(^DD(58.8112,6,0),"^",2)
- +6 SET DIC="^PSD(58.811,"_DA(2)_",1,"_DA(1)_",2,"
- SET DIC(0)="AEMQL"
- SET DIC("A")="CREDIT MEMO: "
- SET DR=.01
- SET DLAYGO=58.811
- +7 FOR
- LOCK +^PSD(58.811,PSAIEN,1,PSAINV,2,0):0
- IF $TEST
- QUIT
- +8 DO ^DIC
- KILL DLAYGO
- IF Y<0
- SET PSAOUT=1
- KILL DIC
- QUIT
- +9 SET DIE=DIC
- SET DR="1;2;3"
- SET (PSADJDA,DA)=+Y
- DO ^DIE
- KILL DA,DIE,DIC
- LOCK -^PSD(58.811,PSAIEN,1,PSAINV,2,0)
- +10 SET PSACRED=PSACRED+$PIECE($GET(^PSD(58.811,PSAIEN,1,PSAINV,2,PSADJDA,0)),"^",3)
- +11 IF PSAIECST=$JUSTIFY((PSAAECST+PSACRED),2)
- SET DA(1)=PSAIEN
- SET DA=PSAINV
- SET DIE="^PSD(58.811,"_DA(1)_",1,"
- SET DR="10////0"
- DO ^DIE
- KILL DIE
- +12 WRITE !!,"Invoice: "_$PIECE($GET(^PSD(58.811,PSAIEN,1,PSAINV,0)),"^")
- SET PSALEN=$LENGTH($PIECE($GET(^PSD(58.811,PSAIEN,1,PSAINV,0)),"^"))+11
- +13 WRITE ?PSALEN,"Total Invoiced Cost: "_$JUSTIFY(PSAIECST,9,2),!?PSALEN,"Total Adjusted Cost: "_$JUSTIFY(PSAAECST,9,2)
- +14 WRITE !?PSALEN,"Total Credits : "_$JUSTIFY(PSACRED,9,2)
- +15 WRITE !?PSALEN,"Difference : "_$JUSTIFY((PSAIECST-(PSAAECST+PSACRED)),9,2),!
- End DoDot:1
- IF PSAOUT
- QUIT
- +16 QUIT
- +17 ;
- CREDHELP ;Extended help to 'Select invoices'
- +1 WRITE !?5,"Enter the numbers to the left of the invoices for which you want to",!?5,"enter credit memos. To select more than one invoice number, enter"
- +2 WRITE !?5,"the numbers to the left of the invoices separated by a comma or a dash.",!!?5,"For example: Enter 1,2,3,5 or 1-3,5"
- +3 QUIT
