- PSAORDP1 ;BIR/JMB-Print Orders - CONT'D ;9/19/97
- ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,12,21,61,65,67**; 10/24/97;Build 15
- ;This routine prints invoices.
- ;
- ;References to global ^DIC(51.5 are covered by IA #1931
- ;References to global ^PSDRUG( are covered by IA #2095
- ;References to global ^PSDRUG("C" are covered by IA #2095
- ;
- DQ S IOM=80 D NOW^%DTC S Y=% D DD^%DT S PSARUN=$E(Y,1,18),PSAPAGE=1,$P(PSASLN,"-",80)="",$P(PSADLN,"=",80)="",(PSADJDRG,PSAOUT)=0,PSAFPG=1
- S PSAEND=0,PSAORDER=$P(^PSD(58.811,PSAORD,0),"^") D HEADER^PSAORDP2
- S PSAIN=$G(^PSD(58.811,PSAORD,1,PSAINV,0)),PSAINVN=$P(PSAIN,"^"),PSASTA=$P(PSAIN,"^",3),PSADEL=+$P(PSAIN,"^",6),PSAREC=+$P(PSAIN,"^",7)
- START W !,"PRIME VENDOR : ",$S($P($G(^PSD(58.811,PSAORD,0)),"^",2)'="":$P($G(^(0)),"^",2),1:"UNKNOWN")
- W !!,"ORDER# : "_PSAORDER,?40,"ORDER DATE : "_$$DATE($P(PSAIN,"^",4))
- W !,"INVOICE#: "_PSAINVN,?40,"INVOICE DATE : "_$$DATE($P(PSAIN,"^",2))
- W !,"STATUS : "_$S(PSASTA="P":"PROCESSED",PSASTA="V":"VERIFIED",PSASTA="L":"LOCKED VERIFYING",PSASTA="C":"COMPLETED",1:"UNKNOWN")_$S(+$P(PSAIN,"^",13):" (SUPPLY INVOICE)",1:"") ;;<*65 RJS>
- W ?40,"DELIVERY DATE: "_$S(PSADEL:$$DATE(PSADEL),1:"UNKNOWN")
- W !?40,"DATE RECEIVED: "_$S(PSAREC:$$DATE(PSAREC),PSADEL:$$DATE(PSADEL),1:"UNKNOWN"),!
- S PSADJDRG=0 S (PSAIECST,PSAAECST)=0 D LINE
- ;
- EXIT ;Kills
- K %,DIR,DIRUT,PSAAECST,PSACIEN,PSADATA,PSADATE,PSADEC,PSADEL,PSADJ,PSADJD,PSADJDP,PSADJDRG,PSADJSUP,PSADJDV,PSADPDT,PSADPDUZ,PSADVDT,PSADVDUZ,PSADJO,PSADJOP,PSADJOV
- K PSADJP,PSADJPP,PSADJPV,PSADJQ,PSADJQP,PSADJQV,PSADLN,PSADRG,PSAECOST,PSAEND,PSAFPG,PSAICOST,PSAIECST,PSAIN,PSAINVN
- K PSALN,PSAMORE,PSANDC,PSANODE,PSAOPDT,PSAOPDUZ,PSAORDER,PSAOU,PSAOVDT,PSAOVDUZ,PSAPAGE,PSAPPDT,PSAPPDUZ,PSAPRICE
- K PSAPVDT,PSAPVDUZ,PSAQPDT,PSAQPDUZ,PSAQPREA,PSAQVDT,PSAQVDUZ,PSAQVREA,PSAREC,PSARUN,PSAS,PSASLN,PSASS,PSASTA,PSATOT,Y
- Q
- ;
- DATE(PSADATE) ;convert date
- S %=$E(PSADATE,4,5)_"/"_$E(PSADATE,6,7)_"/"_$E(PSADATE,2,3)
- I $TR(%,"/")="" S %="UNKNOWN"
- Q %
- ;
- LINE ;print line items
- D LINEHDR^PSAORDP2 S (PSAICOST,PSALN,PSATOT)=0
- F S PSALN=+$O(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN)) Q:'PSALN!(PSAOUT) D Q:PSAOUT
- .Q:'$D(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,0))
- .S PSADATA=^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,0)
- .K PSADJQP,PSAQPDUZ,PSAQPDT,PSAQPREA,PSADJQV,PSAQVDUZ,PSAQVDT,PSAQVREA
- .K PSADJOP,PSAOPDUZ,PSAOPDT,PSADJOV,PSAOVDUZ,PSAOVDT
- .K PSADJPP,PSAPPDUZ,PSAPPDT,PSADJPV,PSAPVDUZ,PSAPVDT
- .K PSADJDP,PSADPDUZ,PSADPDT,PSADJDV,PSADVDUZ,PSADVDT
- .S PSADJSUP=0
- .I $D(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2)) S PSAMORE=4 D
- ..S:+$P(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2),"^") PSAMORE=5
- ..S:+$P(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2),"^",2) PSAMORE=PSAMORE+1
- .E S PSAMORE=4
- .I ($Y+PSAMORE)>IOSL D:$E(IOST,1,2)="C-" SCREEN^PSAORDP2 Q:PSAOUT D HEADER^PSAORDP2,LINEHDR^PSAORDP2
- .W !,$P(PSADATA,"^")
- DRUG .S PSADRG=0,PSADJ=+$O(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,1,"B","D",0))
- .I $G(PSADJ) D
- ..S PSANODE=$G(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,1,PSADJ,0))
- ..S PSADJD=$S($P(PSANODE,"^",6)'="":$P(PSANODE,"^",6),1:$P(PSANODE,"^",2))
- ..I $G(PSADJD),$L(PSADJD)=$L(+PSADJD),$P($G(^PSDRUG(+PSADJD,0)),"^")'="" D Q
- ...W ?8,"*"_$P($G(^PSDRUG(+PSADJD,0)),"^") S PSADJDRG=1,PSADRG=PSADJD
- ...I $P(PSANODE,"^",6)'="" S PSADJDV=$P(PSANODE,"^",6),PSADVDT=$P(PSANODE,"^",8),PSADVDUZ=$P(PSANODE,"^",9)
- ...I $P(PSANODE,"^",2)'="" S PSADJDP=$P(PSANODE,"^",2),PSADPDT=$P(PSANODE,"^",4),PSADPDUZ=$P(PSANODE,"^",5)
- ..I $G(PSADJD),$L(PSADJD)=$L(+PSADJD),$P($G(^PSDRUG(+PSADJD,0)),"^")="" S PSADJ=0 Q
- ..W ?7,"**"_PSADJD S PSADJSUP=1,PSADRG=0
- ..I $P(PSANODE,"^",6)'="" S PSADJDV=$P(PSANODE,"^",6),PSADVDT=$P(PSANODE,"^",8),PSADVDUZ=$P(PSANODE,"^",9)
- ..I $P(PSANODE,"^",2)'="" S PSADJDP=$P(PSANODE,"^",2),PSADPDT=$P(PSANODE,"^",4),PSADPDUZ=$P(PSANODE,"^",5)
- .I '$G(PSADJ) D
- ..S PSADRG=$S(+$P(PSADATA,"^",2)&($P($G(^PSDRUG(+$P(PSADATA,"^",2),0)),"^")'=""):+$P(PSADATA,"^",2),1:0)
- ..W ?9,$S(+$P(PSADATA,"^",2)&($P($G(^PSDRUG(+$P(PSADATA,"^",2),0)),"^")'=""):$P(^PSDRUG(+$P(PSADATA,"^",2),0),"^"),1:"DRUG UNKNOWN")
- CS .I +$P(PSADATA,"^",10) W " (CONTROLLED SUBS)" I $P($G(^PSD(58.8,+$P(PSAIN,"^",12),1,PSADRG,0)),"^",14),$P($G(^(0)),"^",14)'>DT W !?5,"*** INACTIVE IN MASTER VAULT ***"
- .E I PSADRG,$P($G(^PSD(58.8,+$P(PSAIN,"^",5),1,PSADRG,0)),"^",14),$P($G(^(0)),"^",14)'>DT W !?5,"*** INACTIVE IN PHARMACY LOCATION ***"
- .I PSADRG,$D(^PSDRUG(+PSADRG,"I")) W !?5,"*** INACTIVE IN DRUG FILE ***"
- .;
- UPC .W:$P(PSADATA,"^",13)'="" !?9,"UPC: "_$P(PSADATA,"^",13)
- NDC .S PSANDC=$P(PSADATA,"^",11)
- .I $E(PSANDC)'="S" D PSANDC1^PSAHELP S PSANDC=PSANDCX K PSANDCX W !?9,PSANDC
- .S PSASUB=$S(+$P($G(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2)),"^",3):+$P($G(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2)),"^",3),$G(PSANDC)'="":$S(+$O(^PSDRUG("C",PSANDC,+PSADRG,0)):+$O(^PSDRUG("C",PSANDC,+PSADRG,0)),1:0),1:0)
- VSN .W ?25,$S($P(PSADATA,"^",12)'="":$P(PSADATA,"^",12),1:"VSN UNKNOWN")
- .;
- QTY .;No Adj. Qty
- .S PSAIECST=PSAIECST+($P(PSADATA,"^",3)*$P(PSADATA,"^",5))
- .S PSADJP=0,PSADJ=+$O(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,1,"B","P",0))
- .I $G(PSADJ) S PSANODE=$G(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,1,PSADJ,0)),PSAPRICE=$S($P(PSANODE,"^",6)'="":$P(PSANODE,"^",6),1:+$P(PSANODE,"^",2))
- .I '$G(PSADJ) S PSAPRICE=$P(PSADATA,"^",5)
- .S PSADJQ="",PSADJ=+$O(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,1,"B","Q",0))
- .I $G(PSADJ) S PSANODE=$G(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,1,PSADJ,0)),PSADJQ=$S($P(PSANODE,"^",6)'="":+$P(PSANODE,"^",6),1:$P(PSANODE,"^",2))
- .;Adj. Qty
- .I $G(PSADJQ) D
- ..I $P(PSANODE,"^",6)'="" S PSADJQV=$P(PSANODE,"^",6),PSAQVREA=$P(PSANODE,"^",7),PSAQVDT=$P(PSANODE,"^",8),PSAQVDUZ=$P(PSANODE,"^",9)
- ..I $P(PSANODE,"^",2)'="" S PSADJQP=$P(PSANODE,"^",2),PSAQPREA=$P(PSANODE,"^",3),PSAQPDT=$P(PSANODE,"^",4),PSAQPDUZ=$P(PSANODE,"^",5)
- ..S PSAECOST=PSADJQ*PSAPRICE,PSAAECST=PSAAECST+PSAECOST
- ..W ?40,$S($G(PSADJQV)'="":$J(PSADJQV,6),1:$J(PSADJQP,6))_"("_$P(PSADATA,"^",3)_")"
- .I '$G(PSADJQ) W ?40,$J($P(PSADATA,"^",3),6) S PSAECOST=$P(PSADATA,"^",3)*PSAPRICE,PSAAECST=PSAAECST+PSAECOST
- .;
- OU .;Order Unit
- .S PSAOU=$S(+$P(PSADATA,"^",4):$P($G(^DIC(51.5,+$P(PSADATA,"^",4),0)),"^"),+PSASUB&(+$P($G(^PSDRUG(PSADRG,1,+PSASUB,0)),"^",5)):$P($G(^DIC(51.5,+$P($G(^PSDRUG(PSADRG,1,+PSASUB,0)),"^",5),0)),"^"),1:"")
- .S PSADJO="",PSADJ=+$O(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,1,"B","O",0))
- .I $G(PSADJ) S PSANODE=$G(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,1,PSADJ,0)),PSADJO=$S($P(PSANODE,"^",6)'="":$P(PSANODE,"^",6),1:$P(PSANODE,"^",2))
- .;Adj. Order Unit
- .I PSADJO'="" D
- ..I $P(PSANODE,"^",6)'="" S PSADJOV=$P(PSANODE,"^",6),PSAOVDT=$P(PSANODE,"^",8),PSAOVDUZ=$P(PSANODE,"^",9)
- ..I $P(PSANODE,"^",2)'="" S PSADJOP=$P(PSANODE,"^",2),PSAOPDT=$P(PSANODE,"^",4),PSAOPDUZ=$P(PSANODE,"^",5)
- ..W ?53,$S(+PSADJO:$P($G(^DIC(51.5,+PSADJO,0)),"^"),1:"UNKNOWN")_" ("_$S(PSAOU'="":PSAOU,1:"")_")"
- .I PSADJO="" W ?53,$S(PSAOU'="":PSAOU,1:"()")
- .;
- PRICE .;Unit price
- .S PSADEC=$S($L($P($P(PSADATA,"^",5),".",2))>1:$L($P($P(PSADATA,"^",5),".",2)),1:2)
- .S PSADJP=0,PSADJ=+$O(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,1,"B","P",0))
- .I $G(PSADJ) S PSANODE=$G(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,1,PSADJ,0)),PSADJP=$S(+$P(PSANODE,"^",6):+$P(PSANODE,"^",6),1:+$P(PSANODE,"^",2))
- .;Adj. Unit Price
- .I $G(PSADJP) D
- ..I +$P(PSANODE,"^",6) S PSADJPV=$P(PSANODE,"^",6),PSAPVDT=$P(PSANODE,"^",8),PSAPVDUZ=$P(PSANODE,"^",9)
- ..I +$P(PSANODE,"^",2) S PSADJPP=$P(PSANODE,"^",2),PSAPPDT=$P(PSANODE,"^",4),PSAPPDUZ=$P(PSANODE,"^",5)
- ..W ?60,$J(PSADJP,7,2)_" ("_$S(+$P(PSADATA,"^",5):$P(PSADATA,"^",5),$P(PSADATA,"^",5)=0:0,1:"")_")"
- .I '$G(PSADJP) D
- ..I +$P(PSADATA,"^",5)!($P(PSADATA,"^",5)=0) W ?60,$S(+$P(PSADATA,"^",5):$J($P(PSADATA,"^",5),7,PSADEC),1:0) Q
- ..W ?65,"(Blank)"
- .;
- XCOST .;Extended cost
- .W:PSADJP ?67,$J(PSAECOST,7,2) W:'PSADJP ?70,$J(PSAECOST,9,2)
- .;
- LEVELS .;DAVE B (PSA*3*3)
- .S OU=$P($G(^PSDRUG(+PSADRG,660)),"^",2) I OU'="" S OU=$P($G(^DIC(51.5,OU,0)),"^",1)
- .W !!,"Drug file Data - Dispense Unit: ",$P($G(^PSDRUG(+PSADRG,660)),"^",8),?40,"Order Unit : ",$G(OU)
- .;W !,?20," Disp. Unit: ",$P($G(^PSDRUG(+PSADRG,660)),"^",8)
- .W " DUOU: ",$P($G(^PSDRUG(+PSADRG,660)),"^",5)
- .W !,"Invoiced ",?40,"Order Unit : ",$S($P(PSADATA,"^",4)=""!($P(PSADATA,"^",4)=0):"None Sent",1:$S($P(PSADATA,"^",4)["~":"Invalid: "_$P(PSADATA,"^",4),1:$P(^DIC(51.5,$P(PSADATA,"^",4),0),"^")))
- .W " DUOU: ",$S(+$P($G(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2)),"^")'=0:$P(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2),"^"),1:"nothing changed")
- .K OU
- .W:+$P($G(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2)),"^",4)'=0 !?9,"STOCK LEVEL : "_$FN(+$P(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2),"^",4),",")
- .W:+$P($G(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2)),"^",2)'=0 !?9,"REORDER LEVEL: "_$FN(+$P(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2),"^",2),",")
- .;
- .;BGN 67
- .D DISP2^PSAP67
- .;END 67
- .I $Y+5>IOSL D:$E(IOST,1,2)="C-" SCREEN^PSAORDP2 Q:PSAOUT D HEADER^PSAORDP2 D LINEHDR^PSAORDP2
- .D ^PSAORDP2 Q:PSAOUT
- .W !
- Q:PSAOUT
- I $Y+5>IOSL D:$E(IOST,1,2)="C-" SCREEN^PSAORDP2 Q:PSAOUT D HEADER^PSAORDP2
- W !,PSASLN
- S PSADJSUP=$S($P($G(^PSD(58.811,PSAORD,1,PSAINV,0)),"^",13)=1:1,1:0)
- I $G(PSAAECST)'=$G(PSAIECST) D
- .W !?47,"TOTAL ADJUSTED COST",?67,$J(PSAAECST,12,2),!
- .I +$O(^PSD(58.811,PSAORD,1,PSAINV,2,0)) D
- ..S PSACIEN=0 F S PSACIEN=+$O(^PSD(58.811,PSAORD,1,PSAINV,2,PSACIEN)) Q:'PSACIEN D
- ...Q:'$D(^PSD(58.811,PSAORD,1,PSAINV,2,PSACIEN,0))
- ...I $Y+3>IOSL D:$E(IOST,1,2)="C-" SCREEN^PSAORDP2 Q:PSAOUT D HEADER^PSAORDP2
- ...W:+$P(^PSD(58.811,PSAORD,1,PSAINV,2,PSACIEN,0),"^",3) ?55,"CREDIT MEMO "_$J($P(^(0),"^",3),12,2),!
- W !?47,"TOTAL INVOICED COST",?67,$J(PSAIECST,12,2)
- S PSAEND=1
- I $E(IOST)'="C" D
- .I PSADJDRG D:$Y+4>IOSL HEADER^PSAORDP2 W !!," * THE DRUG WAS MATCHED TO THE DRUG FILE.",!
- .I PSADJSUP D:$Y+4>IOSL HEADER^PSAORDP2 W !,"** THE ITEM IS A SUPPLY ITEM.",!
- D:$E(IOST,1,2)="C-" SCREEN^PSAORDP2
- W !
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSAORDP1 9970 printed Jan 18, 2025@02:51:07 Page 2
- PSAORDP1 ;BIR/JMB-Print Orders - CONT'D ;9/19/97
- +1 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,12,21,61,65,67**; 10/24/97;Build 15
- +2 ;This routine prints invoices.
- +3 ;
- +4 ;References to global ^DIC(51.5 are covered by IA #1931
- +5 ;References to global ^PSDRUG( are covered by IA #2095
- +6 ;References to global ^PSDRUG("C" are covered by IA #2095
- +7 ;
- DQ SET IOM=80
- DO NOW^%DTC
- SET Y=%
- DO DD^%DT
- SET PSARUN=$EXTRACT(Y,1,18)
- SET PSAPAGE=1
- SET $PIECE(PSASLN,"-",80)=""
- SET $PIECE(PSADLN,"=",80)=""
- SET (PSADJDRG,PSAOUT)=0
- SET PSAFPG=1
- +1 SET PSAEND=0
- SET PSAORDER=$PIECE(^PSD(58.811,PSAORD,0),"^")
- DO HEADER^PSAORDP2
- +2 SET PSAIN=$GET(^PSD(58.811,PSAORD,1,PSAINV,0))
- SET PSAINVN=$PIECE(PSAIN,"^")
- SET PSASTA=$PIECE(PSAIN,"^",3)
- SET PSADEL=+$PIECE(PSAIN,"^",6)
- SET PSAREC=+$PIECE(PSAIN,"^",7)
- START WRITE !,"PRIME VENDOR : ",$SELECT($PIECE($GET(^PSD(58.811,PSAORD,0)),"^",2)'="":$PIECE($GET(^(0)),"^",2),1:"UNKNOWN")
- +1 WRITE !!,"ORDER# : "_PSAORDER,?40,"ORDER DATE : "_$$DATE($PIECE(PSAIN,"^",4))
- +2 WRITE !,"INVOICE#: "_PSAINVN,?40,"INVOICE DATE : "_$$DATE($PIECE(PSAIN,"^",2))
- +3 ;;<*65 RJS>
- WRITE !,"STATUS : "_$SELECT(PSASTA="P":"PROCESSED",PSASTA="V":"VERIFIED",PSASTA="L":"LOCKED VERIFYING",PSASTA="C":"COMPLETED",1:"UNKNOWN")_$SELECT(+$PIECE(PSAIN,"^",13):" (SUPPLY INVOICE)",1:"")
- +4 WRITE ?40,"DELIVERY DATE: "_$SELECT(PSADEL:$$DATE(PSADEL),1:"UNKNOWN")
- +5 WRITE !?40,"DATE RECEIVED: "_$SELECT(PSAREC:$$DATE(PSAREC),PSADEL:$$DATE(PSADEL),1:"UNKNOWN"),!
- +6 SET PSADJDRG=0
- SET (PSAIECST,PSAAECST)=0
- DO LINE
- +7 ;
- EXIT ;Kills
- +1 KILL %,DIR,DIRUT,PSAAECST,PSACIEN,PSADATA,PSADATE,PSADEC,PSADEL,PSADJ,PSADJD,PSADJDP,PSADJDRG,PSADJSUP,PSADJDV,PSADPDT,PSADPDUZ,PSADVDT,PSADVDUZ,PSADJO,PSADJOP,PSADJOV
- +2 KILL PSADJP,PSADJPP,PSADJPV,PSADJQ,PSADJQP,PSADJQV,PSADLN,PSADRG,PSAECOST,PSAEND,PSAFPG,PSAICOST,PSAIECST,PSAIN,PSAINVN
- +3 KILL PSALN,PSAMORE,PSANDC,PSANODE,PSAOPDT,PSAOPDUZ,PSAORDER,PSAOU,PSAOVDT,PSAOVDUZ,PSAPAGE,PSAPPDT,PSAPPDUZ,PSAPRICE
- +4 KILL PSAPVDT,PSAPVDUZ,PSAQPDT,PSAQPDUZ,PSAQPREA,PSAQVDT,PSAQVDUZ,PSAQVREA,PSAREC,PSARUN,PSAS,PSASLN,PSASS,PSASTA,PSATOT,Y
- +5 QUIT
- +6 ;
- DATE(PSADATE) ;convert date
- +1 SET %=$EXTRACT(PSADATE,4,5)_"/"_$EXTRACT(PSADATE,6,7)_"/"_$EXTRACT(PSADATE,2,3)
- +2 IF $TRANSLATE(%,"/")=""
- SET %="UNKNOWN"
- +3 QUIT %
- +4 ;
- LINE ;print line items
- +1 DO LINEHDR^PSAORDP2
- SET (PSAICOST,PSALN,PSATOT)=0
- +2 FOR
- SET PSALN=+$ORDER(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN))
- if 'PSALN!(PSAOUT)
- QUIT
- Begin DoDot:1
- +3 if '$DATA(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,0))
- QUIT
- +4 SET PSADATA=^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,0)
- +5 KILL PSADJQP,PSAQPDUZ,PSAQPDT,PSAQPREA,PSADJQV,PSAQVDUZ,PSAQVDT,PSAQVREA
- +6 KILL PSADJOP,PSAOPDUZ,PSAOPDT,PSADJOV,PSAOVDUZ,PSAOVDT
- +7 KILL PSADJPP,PSAPPDUZ,PSAPPDT,PSADJPV,PSAPVDUZ,PSAPVDT
- +8 KILL PSADJDP,PSADPDUZ,PSADPDT,PSADJDV,PSADVDUZ,PSADVDT
- +9 SET PSADJSUP=0
- +10 IF $DATA(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2))
- SET PSAMORE=4
- Begin DoDot:2
- +11 if +$PIECE(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2),"^")
- SET PSAMORE=5
- +12 if +$PIECE(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2),"^",2)
- SET PSAMORE=PSAMORE+1
- End DoDot:2
- +13 IF '$TEST
- SET PSAMORE=4
- +14 IF ($Y+PSAMORE)>IOSL
- if $EXTRACT(IOST,1,2)="C-"
- DO SCREEN^PSAORDP2
- if PSAOUT
- QUIT
- DO HEADER^PSAORDP2
- DO LINEHDR^PSAORDP2
- +15 WRITE !,$PIECE(PSADATA,"^")
- DRUG SET PSADRG=0
- SET PSADJ=+$ORDER(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,1,"B","D",0))
- +1 IF $GET(PSADJ)
- Begin DoDot:2
- +2 SET PSANODE=$GET(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,1,PSADJ,0))
- +3 SET PSADJD=$SELECT($PIECE(PSANODE,"^",6)'="":$PIECE(PSANODE,"^",6),1:$PIECE(PSANODE,"^",2))
- +4 IF $GET(PSADJD)
- IF $LENGTH(PSADJD)=$LENGTH(+PSADJD)
- IF $PIECE($GET(^PSDRUG(+PSADJD,0)),"^")'=""
- Begin DoDot:3
- +5 WRITE ?8,"*"_$PIECE($GET(^PSDRUG(+PSADJD,0)),"^")
- SET PSADJDRG=1
- SET PSADRG=PSADJD
- +6 IF $PIECE(PSANODE,"^",6)'=""
- SET PSADJDV=$PIECE(PSANODE,"^",6)
- SET PSADVDT=$PIECE(PSANODE,"^",8)
- SET PSADVDUZ=$PIECE(PSANODE,"^",9)
- +7 IF $PIECE(PSANODE,"^",2)'=""
- SET PSADJDP=$PIECE(PSANODE,"^",2)
- SET PSADPDT=$PIECE(PSANODE,"^",4)
- SET PSADPDUZ=$PIECE(PSANODE,"^",5)
- End DoDot:3
- QUIT
- +8 IF $GET(PSADJD)
- IF $LENGTH(PSADJD)=$LENGTH(+PSADJD)
- IF $PIECE($GET(^PSDRUG(+PSADJD,0)),"^")=""
- SET PSADJ=0
- QUIT
- +9 WRITE ?7,"**"_PSADJD
- SET PSADJSUP=1
- SET PSADRG=0
- +10 IF $PIECE(PSANODE,"^",6)'=""
- SET PSADJDV=$PIECE(PSANODE,"^",6)
- SET PSADVDT=$PIECE(PSANODE,"^",8)
- SET PSADVDUZ=$PIECE(PSANODE,"^",9)
- +11 IF $PIECE(PSANODE,"^",2)'=""
- SET PSADJDP=$PIECE(PSANODE,"^",2)
- SET PSADPDT=$PIECE(PSANODE,"^",4)
- SET PSADPDUZ=$PIECE(PSANODE,"^",5)
- End DoDot:2
- +12 IF '$GET(PSADJ)
- Begin DoDot:2
- +13 SET PSADRG=$SELECT(+$PIECE(PSADATA,"^",2)&($PIECE($GET(^PSDRUG(+$PIECE(PSADATA,"^",2),0)),"^")'=""):+$PIECE(PSADATA,"^",2),1:0)
- +14 WRITE ?9,$SELECT(+$PIECE(PSADATA,"^",2)&($PIECE($GET(^PSDRUG(+$PIECE(PSADATA,"^",2),0)),"^")'=""):$PIECE(^PSDRUG(+$PIECE(PSADATA,"^",2),0),"^"),1:"DRUG UNKNOWN")
- End DoDot:2
- CS IF +$PIECE(PSADATA,"^",10)
- WRITE " (CONTROLLED SUBS)"
- IF $PIECE($GET(^PSD(58.8,+$PIECE(PSAIN,"^",12),1,PSADRG,0)),"^",14)
- IF $PIECE($GET(^(0)),"^",14)'>DT
- WRITE !?5,"*** INACTIVE IN MASTER VAULT ***"
- +1 IF '$TEST
- IF PSADRG
- IF $PIECE($GET(^PSD(58.8,+$PIECE(PSAIN,"^",5),1,PSADRG,0)),"^",14)
- IF $PIECE($GET(^(0)),"^",14)'>DT
- WRITE !?5,"*** INACTIVE IN PHARMACY LOCATION ***"
- +2 IF PSADRG
- IF $DATA(^PSDRUG(+PSADRG,"I"))
- WRITE !?5,"*** INACTIVE IN DRUG FILE ***"
- +3 ;
- UPC if $PIECE(PSADATA,"^",13)'=""
- WRITE !?9,"UPC: "_$PIECE(PSADATA,"^",13)
- NDC SET PSANDC=$PIECE(PSADATA,"^",11)
- +1 IF $EXTRACT(PSANDC)'="S"
- DO PSANDC1^PSAHELP
- SET PSANDC=PSANDCX
- KILL PSANDCX
- WRITE !?9,PSANDC
- +2 SET PSASUB=$SELECT(+$PIECE($GET(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2)),"^",3):+$PIECE($GET(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2)),"^",3),$GET(PSANDC)'="":$SELECT(+$ORDER(^PSDRUG("C",PSANDC,+PSADRG,0)):+$ORDER(^PSDRUG("C",PSANDC,+PSADR
- G,0)),1:0),1:0)
- VSN WRITE ?25,$SELECT($PIECE(PSADATA,"^",12)'="":$PIECE(PSADATA,"^",12),1:"VSN UNKNOWN")
- +1 ;
- QTY ;No Adj. Qty
- +1 SET PSAIECST=PSAIECST+($PIECE(PSADATA,"^",3)*$PIECE(PSADATA,"^",5))
- +2 SET PSADJP=0
- SET PSADJ=+$ORDER(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,1,"B","P",0))
- +3 IF $GET(PSADJ)
- SET PSANODE=$GET(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,1,PSADJ,0))
- SET PSAPRICE=$SELECT($PIECE(PSANODE,"^",6)'="":$PIECE(PSANODE,"^",6),1:+$PIECE(PSANODE,"^",2))
- +4 IF '$GET(PSADJ)
- SET PSAPRICE=$PIECE(PSADATA,"^",5)
- +5 SET PSADJQ=""
- SET PSADJ=+$ORDER(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,1,"B","Q",0))
- +6 IF $GET(PSADJ)
- SET PSANODE=$GET(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,1,PSADJ,0))
- SET PSADJQ=$SELECT($PIECE(PSANODE,"^",6)'="":+$PIECE(PSANODE,"^",6),1:$PIECE(PSANODE,"^",2))
- +7 ;Adj. Qty
- +8 IF $GET(PSADJQ)
- Begin DoDot:2
- +9 IF $PIECE(PSANODE,"^",6)'=""
- SET PSADJQV=$PIECE(PSANODE,"^",6)
- SET PSAQVREA=$PIECE(PSANODE,"^",7)
- SET PSAQVDT=$PIECE(PSANODE,"^",8)
- SET PSAQVDUZ=$PIECE(PSANODE,"^",9)
- +10 IF $PIECE(PSANODE,"^",2)'=""
- SET PSADJQP=$PIECE(PSANODE,"^",2)
- SET PSAQPREA=$PIECE(PSANODE,"^",3)
- SET PSAQPDT=$PIECE(PSANODE,"^",4)
- SET PSAQPDUZ=$PIECE(PSANODE,"^",5)
- +11 SET PSAECOST=PSADJQ*PSAPRICE
- SET PSAAECST=PSAAECST+PSAECOST
- +12 WRITE ?40,$SELECT($GET(PSADJQV)'="":$JUSTIFY(PSADJQV,6),1:$JUSTIFY(PSADJQP,6))_"("_$PIECE(PSADATA,"^",3)_")"
- End DoDot:2
- +13 IF '$GET(PSADJQ)
- WRITE ?40,$JUSTIFY($PIECE(PSADATA,"^",3),6)
- SET PSAECOST=$PIECE(PSADATA,"^",3)*PSAPRICE
- SET PSAAECST=PSAAECST+PSAECOST
- +14 ;
- OU ;Order Unit
- +1 SET PSAOU=$SELECT(+$PIECE(PSADATA,"^",4):$PIECE($GET(^DIC(51.5,+$PIECE(PSADATA,"^",4),0)),"^"),+PSASUB&(+$PIECE($GET(^PSDRUG(PSADRG,1,+PSASUB,0)),"^",5)):$PIECE($GET(^DIC(51.5,+$PIECE($GET(^PSDRUG(PSADRG,1,+PSASUB,0)),"^",5),0)),"^"),1:
- "")
- +2 SET PSADJO=""
- SET PSADJ=+$ORDER(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,1,"B","O",0))
- +3 IF $GET(PSADJ)
- SET PSANODE=$GET(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,1,PSADJ,0))
- SET PSADJO=$SELECT($PIECE(PSANODE,"^",6)'="":$PIECE(PSANODE,"^",6),1:$PIECE(PSANODE,"^",2))
- +4 ;Adj. Order Unit
- +5 IF PSADJO'=""
- Begin DoDot:2
- +6 IF $PIECE(PSANODE,"^",6)'=""
- SET PSADJOV=$PIECE(PSANODE,"^",6)
- SET PSAOVDT=$PIECE(PSANODE,"^",8)
- SET PSAOVDUZ=$PIECE(PSANODE,"^",9)
- +7 IF $PIECE(PSANODE,"^",2)'=""
- SET PSADJOP=$PIECE(PSANODE,"^",2)
- SET PSAOPDT=$PIECE(PSANODE,"^",4)
- SET PSAOPDUZ=$PIECE(PSANODE,"^",5)
- +8 WRITE ?53,$SELECT(+PSADJO:$PIECE($GET(^DIC(51.5,+PSADJO,0)),"^"),1:"UNKNOWN")_" ("_$SELECT(PSAOU'="":PSAOU,1:"")_")"
- End DoDot:2
- +9 IF PSADJO=""
- WRITE ?53,$SELECT(PSAOU'="":PSAOU,1:"()")
- +10 ;
- PRICE ;Unit price
- +1 SET PSADEC=$SELECT($LENGTH($PIECE($PIECE(PSADATA,"^",5),".",2))>1:$LENGTH($PIECE($PIECE(PSADATA,"^",5),".",2)),1:2)
- +2 SET PSADJP=0
- SET PSADJ=+$ORDER(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,1,"B","P",0))
- +3 IF $GET(PSADJ)
- SET PSANODE=$GET(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,1,PSADJ,0))
- SET PSADJP=$SELECT(+$PIECE(PSANODE,"^",6):+$PIECE(PSANODE,"^",6),1:+$PIECE(PSANODE,"^",2))
- +4 ;Adj. Unit Price
- +5 IF $GET(PSADJP)
- Begin DoDot:2
- +6 IF +$PIECE(PSANODE,"^",6)
- SET PSADJPV=$PIECE(PSANODE,"^",6)
- SET PSAPVDT=$PIECE(PSANODE,"^",8)
- SET PSAPVDUZ=$PIECE(PSANODE,"^",9)
- +7 IF +$PIECE(PSANODE,"^",2)
- SET PSADJPP=$PIECE(PSANODE,"^",2)
- SET PSAPPDT=$PIECE(PSANODE,"^",4)
- SET PSAPPDUZ=$PIECE(PSANODE,"^",5)
- +8 WRITE ?60,$JUSTIFY(PSADJP,7,2)_" ("_$SELECT(+$PIECE(PSADATA,"^",5):$PIECE(PSADATA,"^",5),$PIECE(PSADATA,"^",5)=0:0,1:"")_")"
- End DoDot:2
- +9 IF '$GET(PSADJP)
- Begin DoDot:2
- +10 IF +$PIECE(PSADATA,"^",5)!($PIECE(PSADATA,"^",5)=0)
- WRITE ?60,$SELECT(+$PIECE(PSADATA,"^",5):$JUSTIFY($PIECE(PSADATA,"^",5),7,PSADEC),1:0)
- QUIT
- +11 WRITE ?65,"(Blank)"
- End DoDot:2
- +12 ;
- XCOST ;Extended cost
- +1 if PSADJP
- WRITE ?67,$JUSTIFY(PSAECOST,7,2)
- if 'PSADJP
- WRITE ?70,$JUSTIFY(PSAECOST,9,2)
- +2 ;
- LEVELS ;DAVE B (PSA*3*3)
- +1 SET OU=$PIECE($GET(^PSDRUG(+PSADRG,660)),"^",2)
- IF OU'=""
- SET OU=$PIECE($GET(^DIC(51.5,OU,0)),"^",1)
- +2 WRITE !!,"Drug file Data - Dispense Unit: ",$PIECE($GET(^PSDRUG(+PSADRG,660)),"^",8),?40,"Order Unit : ",$GET(OU)
- +3 ;W !,?20," Disp. Unit: ",$P($G(^PSDRUG(+PSADRG,660)),"^",8)
- +4 WRITE " DUOU: ",$PIECE($GET(^PSDRUG(+PSADRG,660)),"^",5)
- +5 WRITE !,"Invoiced ",?40,"Order Unit : ",$SELECT($PIECE(PSADATA,"^",4)=""!($PIECE(PSADATA,"^",4)=0):"None Sent",1:$SELECT($PIECE(PSADATA,"^",4)["~":"Invalid: "_$PIECE(PSADATA,"^",4),1:$PIECE(^DIC(51.5,$PIECE(PSADATA,"^",4),0),"^")))
- +6 WRITE " DUOU: ",$SELECT(+$PIECE($GET(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2)),"^")'=0:$PIECE(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2),"^"),1:"nothing changed")
- +7 KILL OU
- +8 if +$PIECE($GET(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2)),"^",4)'=0
- WRITE !?9,"STOCK LEVEL : "_$FNUMBER(+$PIECE(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2),"^",4),",")
- +9 if +$PIECE($GET(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2)),"^",2)'=0
- WRITE !?9,"REORDER LEVEL: "_$FNUMBER(+$PIECE(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2),"^",2),",")
- +10 ;
- +11 ;BGN 67
- +12 DO DISP2^PSAP67
- +13 ;END 67
- +14 IF $Y+5>IOSL
- if $EXTRACT(IOST,1,2)="C-"
- DO SCREEN^PSAORDP2
- if PSAOUT
- QUIT
- DO HEADER^PSAORDP2
- DO LINEHDR^PSAORDP2
- +15 DO ^PSAORDP2
- if PSAOUT
- QUIT
- +16 WRITE !
- End DoDot:1
- if PSAOUT
- QUIT
- +17 if PSAOUT
- QUIT
- +18 IF $Y+5>IOSL
- if $EXTRACT(IOST,1,2)="C-"
- DO SCREEN^PSAORDP2
- if PSAOUT
- QUIT
- DO HEADER^PSAORDP2
- +19 WRITE !,PSASLN
- +20 SET PSADJSUP=$SELECT($PIECE($GET(^PSD(58.811,PSAORD,1,PSAINV,0)),"^",13)=1:1,1:0)
- +21 IF $GET(PSAAECST)'=$GET(PSAIECST)
- Begin DoDot:1
- +22 WRITE !?47,"TOTAL ADJUSTED COST",?67,$JUSTIFY(PSAAECST,12,2),!
- +23 IF +$ORDER(^PSD(58.811,PSAORD,1,PSAINV,2,0))
- Begin DoDot:2
- +24 SET PSACIEN=0
- FOR
- SET PSACIEN=+$ORDER(^PSD(58.811,PSAORD,1,PSAINV,2,PSACIEN))
- if 'PSACIEN
- QUIT
- Begin DoDot:3
- +25 if '$DATA(^PSD(58.811,PSAORD,1,PSAINV,2,PSACIEN,0))
- QUIT
- +26 IF $Y+3>IOSL
- if $EXTRACT(IOST,1,2)="C-"
- DO SCREEN^PSAORDP2
- if PSAOUT
- QUIT
- DO HEADER^PSAORDP2
- +27 if +$PIECE(^PSD(58.811,PSAORD,1,PSAINV,2,PSACIEN,0),"^",3)
- WRITE ?55,"CREDIT MEMO "_$JUSTIFY($PIECE(^(0),"^",3),12,2),!
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +28 WRITE !?47,"TOTAL INVOICED COST",?67,$JUSTIFY(PSAIECST,12,2)
- +29 SET PSAEND=1
- +30 IF $EXTRACT(IOST)'="C"
- Begin DoDot:1
- +31 IF PSADJDRG
- if $Y+4>IOSL
- DO HEADER^PSAORDP2
- WRITE !!," * THE DRUG WAS MATCHED TO THE DRUG FILE.",!
- +32 IF PSADJSUP
- if $Y+4>IOSL
- DO HEADER^PSAORDP2
- WRITE !,"** THE ITEM IS A SUPPLY ITEM.",!
- End DoDot:1
- +33 if $EXTRACT(IOST,1,2)="C-"
- DO SCREEN^PSAORDP2
- +34 WRITE !
- +35 QUIT