- PSAUTL6 ;VMP/PDW-PULL ORDER INVOICE LINE ITEM DATA ;03/28/2005
- ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**42**; 10/24/97
- ;References to ^PSDRUG( are covered by IA #2095
- ;
- ITEM(PSAIEN,PSAIEN1,PSALINE,ITM,FORM) ;RETURN LINE ITEM INFO with data adjusted IN .ITM array by reference
- ;PSAIEN - Order IEN, PSAIEN1 - Invoice IEN, PSALINE - Item IEN
- ; FORM="I" INTERNAL VALUE, ="" EXTERNAL VALUE
- ; ITM return array pass by reference ITM(field number #)= value
- ; .01-Line, 1-Drug, 2-QTY, 3-OU, 4-PPOU, 5-DtProc, 6-Proc, 7-DtVer
- ; 8-Ver, 10-DUOU, 11-ReOrd Lev, 12-CS, 13-NDC(-), 14-VSN, 15-UPC
- ; 16-Syn Node, 17-Stock Lev
- ; code borrowed from PSAVER6 March 25,2005
- N PSACOST,PSACS,PSADASH,PSADATA,PSADJ,PSADJD,PSADJO,PSADJP,PSADJQ
- N PSADRG,PSADT,PSADUOU,PSADUQTY,PSADUREC,PSAIN,PSAINV,PSAINVDT,PSALEN,PSALOC,PSAMSG,PSANDC,PSANODE,PSANPDU,PSANPOU
- N PSAODASH,PSAONDC,PSAORD,PSAOU,PSAPDU,PSAPOU,PSAQTY,PSAREORD,PSASET,PSASTOCK,PSASUP,PSAT,PSATDRG,PSATEMP,PSAVBKG,PSAVDUZ,PSAVEND,PSAVSN,X
- N PSA0QTY,PSASUB,IENS
- I '$L($G(FORM)) S FORM=""
- S PSAIN=^PSD(58.811,PSAIEN,1,PSAIEN1,0)
- S PSADATA=^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,0)
- S PSAVDUZ=$P(PSADATA,"^",9),PSASUP=0
- S PSADJ=+$O(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","D",0))
- I '$G(PSADJ) S PSADRG=$S(+$P(PSADATA,"^",2):+$P(PSADATA,"^",2),1:0) G CS
- 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))
- .I PSADJD'?1.N S PSASUP=1
- .S PSADRG=$S(PSADJ&('PSASUP):+PSADJD,PSADJ&(PSASUP):$G(PSADJD),1:+$P(PSADATA,"^",2))
- .I +PSADJD,$G(PSADJD)=+$G(PSADJD),$P($G(^PSDRUG(+PSADJD,0)),"^")'="" S PSADRG=+PSADJD Q
- .I +PSADJD,$G(PSADJD)=+$G(PSADJD),$P($G(^PSDRUG(+PSADJD,0)),"^")="" S (PSADJ,PSADRG)=0 Q
- CS ;Q:PSASUP!('PSADRG)
- S PSACS=$S(+$P(PSADATA,"^",10):1,1:0)
- S PSADJQ=0,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))
- ;
- ;PSA*3*1 (DAVE B)
- S PSAQTY=$S(($G(PSADJQ)'=""&(+PSADJ)):PSADJQ,1:+$P(PSADATA,"^",3))
- S PSAOU=$S(+$P(PSADATA,"^",4):+$P(PSADATA,"^",4),1:"")
- ;
- ;DAVE B (PSA*3*3)
- ;I +$P($P($G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,2)),"^",5),"~",2) S PSAOU=$P($P($G(^(2)),"^",5),"~",2)
- ;
- S PSADJO=0,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))
- S:$G(PSADJO) PSAOU=$G(PSADJO)
- S PSANDC=$P(PSADATA,"^",11) I FORM="" D PSANDC1^PSAHELP S PSANDC=PSANDCX K PSANDCX
- 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))
- S (PSAPOU,PSANPOU)=$S($G(PSADJP):PSADJP,1:+$P(PSADATA,"^",5)),PSALEN=$L($P(PSANPOU,".")),(PSAPOU,PSANPOU)=$J(PSANPOU,PSALEN,2)
- S PSAVSN=$P(PSADATA,"^",12)
- S PSALOC=$S(+PSACS:+$P(PSAIN,"^",12),1:+$P(PSAIN,"^",5))
- TEMP S PSATEMP=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,2))
- S PSADUOU=+$P(PSATEMP,"^"),PSAREORD=+$P(PSATEMP,"^",2),PSASUB=+$P(PSATEMP,"^",3),PSASTOCK=+$P(PSATEMP,"^",4)
- S PSADUOU=$S(+PSADUOU:+PSADUOU,+PSASUB&(+$P($G(^PSDRUG(PSADRG,1,PSASUB,0)),"^",7)):+$P($G(^PSDRUG(PSADRG,1,PSASUB,0)),"^",7),1:1)
- S PSADUREC=$S(PSADUOU:PSAQTY*PSADUOU,1:0)
- ;
- ;DAVE B (18NOV98)
- ;I PSADUREC=0,$D(PSAQTY),$P($G(^PSDRUG(PSADRG,660)),"^",5)'="" S PSADUREC=(PSAQTY*($P(^PSDRUG(PSADRG,660),"^",5)))
- 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:0)
- 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:0)
- S ITM(.01)=PSALINE,ITM(1)=PSADRG,ITM(2)=PSAQTY,ITM(3)=PSAOU,ITM(4)=PSANPOU,ITM(13)=PSANDC,ITM(10)=PSADUOU
- S IENS=PSALINE_","_PSAIEN1_","_PSAIEN
- F X=5,6,7,8,12,14,15,16,17 S ITM(X)=$$GET1^DIQ(58.81125,IENS,X,FORM)
- I FORM'="I" S ITM(3)=$$GET1^DIQ(51.5,ITM(3),.01) S:+ITM(1)=ITM(1) ITM(1)=$$GET1^DIQ(50,ITM(1),.01) ;also handle supply items ITM(1)=supply item name
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSAUTL6 4277 printed Jan 18, 2025@02:52:12 Page 2
- PSAUTL6 ;VMP/PDW-PULL ORDER INVOICE LINE ITEM DATA ;03/28/2005
- +1 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**42**; 10/24/97
- +2 ;References to ^PSDRUG( are covered by IA #2095
- +3 ;
- ITEM(PSAIEN,PSAIEN1,PSALINE,ITM,FORM) ;RETURN LINE ITEM INFO with data adjusted IN .ITM array by reference
- +1 ;PSAIEN - Order IEN, PSAIEN1 - Invoice IEN, PSALINE - Item IEN
- +2 ; FORM="I" INTERNAL VALUE, ="" EXTERNAL VALUE
- +3 ; ITM return array pass by reference ITM(field number #)= value
- +4 ; .01-Line, 1-Drug, 2-QTY, 3-OU, 4-PPOU, 5-DtProc, 6-Proc, 7-DtVer
- +5 ; 8-Ver, 10-DUOU, 11-ReOrd Lev, 12-CS, 13-NDC(-), 14-VSN, 15-UPC
- +6 ; 16-Syn Node, 17-Stock Lev
- +7 ; code borrowed from PSAVER6 March 25,2005
- +8 NEW PSACOST,PSACS,PSADASH,PSADATA,PSADJ,PSADJD,PSADJO,PSADJP,PSADJQ
- +9 NEW PSADRG,PSADT,PSADUOU,PSADUQTY,PSADUREC,PSAIN,PSAINV,PSAINVDT,PSALEN,PSALOC,PSAMSG,PSANDC,PSANODE,PSANPDU,PSANPOU
- +10 NEW PSAODASH,PSAONDC,PSAORD,PSAOU,PSAPDU,PSAPOU,PSAQTY,PSAREORD,PSASET,PSASTOCK,PSASUP,PSAT,PSATDRG,PSATEMP,PSAVBKG,PSAVDUZ,PSAVEND,PSAVSN,X
- +11 NEW PSA0QTY,PSASUB,IENS
- +12 IF '$LENGTH($GET(FORM))
- SET FORM=""
- +13 SET PSAIN=^PSD(58.811,PSAIEN,1,PSAIEN1,0)
- +14 SET PSADATA=^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,0)
- +15 SET PSAVDUZ=$PIECE(PSADATA,"^",9)
- SET PSASUP=0
- +16 SET PSADJ=+$ORDER(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","D",0))
- +17 IF '$GET(PSADJ)
- SET PSADRG=$SELECT(+$PIECE(PSADATA,"^",2):+$PIECE(PSADATA,"^",2),1:0)
- GOTO CS
- +18 IF $GET(PSADJ)
- Begin DoDot:1
- +19 SET PSANODE=$GET(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,PSADJ,0))
- +20 SET PSADJD=$SELECT($PIECE(PSANODE,"^",6)'="":$PIECE(PSANODE,"^",6),1:$PIECE(PSANODE,"^",2))
- +21 IF PSADJD'?1.N
- SET PSASUP=1
- +22 SET PSADRG=$SELECT(PSADJ&('PSASUP):+PSADJD,PSADJ&(PSASUP):$GET(PSADJD),1:+$PIECE(PSADATA,"^",2))
- +23 IF +PSADJD
- IF $GET(PSADJD)=+$GET(PSADJD)
- IF $PIECE($GET(^PSDRUG(+PSADJD,0)),"^")'=""
- SET PSADRG=+PSADJD
- QUIT
- +24 IF +PSADJD
- IF $GET(PSADJD)=+$GET(PSADJD)
- IF $PIECE($GET(^PSDRUG(+PSADJD,0)),"^")=""
- SET (PSADJ,PSADRG)=0
- QUIT
- End DoDot:1
- CS ;Q:PSASUP!('PSADRG)
- +1 SET PSACS=$SELECT(+$PIECE(PSADATA,"^",10):1,1:0)
- +2 SET PSADJQ=0
- 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 ;
- +5 ;PSA*3*1 (DAVE B)
- +6 SET PSAQTY=$SELECT(($GET(PSADJQ)'=""&(+PSADJ)):PSADJQ,1:+$PIECE(PSADATA,"^",3))
- +7 SET PSAOU=$SELECT(+$PIECE(PSADATA,"^",4):+$PIECE(PSADATA,"^",4),1:"")
- +8 ;
- +9 ;DAVE B (PSA*3*3)
- +10 ;I +$P($P($G(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,2)),"^",5),"~",2) S PSAOU=$P($P($G(^(2)),"^",5),"~",2)
- +11 ;
- +12 SET PSADJO=0
- SET PSADJ=+$ORDER(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","O",0))
- +13 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))
- +14 if $GET(PSADJO)
- SET PSAOU=$GET(PSADJO)
- +15 SET PSANDC=$PIECE(PSADATA,"^",11)
- IF FORM=""
- DO PSANDC1^PSAHELP
- SET PSANDC=PSANDCX
- KILL PSANDCX
- +16 SET PSADJP=0
- SET PSADJ=+$ORDER(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,1,"B","P",0))
- +17 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))
- +18 SET (PSAPOU,PSANPOU)=$SELECT($GET(PSADJP):PSADJP,1:+$PIECE(PSADATA,"^",5))
- SET PSALEN=$LENGTH($PIECE(PSANPOU,"."))
- SET (PSAPOU,PSANPOU)=$JUSTIFY(PSANPOU,PSALEN,2)
- +19 SET PSAVSN=$PIECE(PSADATA,"^",12)
- +20 SET PSALOC=$SELECT(+PSACS:+$PIECE(PSAIN,"^",12),1:+$PIECE(PSAIN,"^",5))
- TEMP SET PSATEMP=$GET(^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSALINE,2))
- +1 SET PSADUOU=+$PIECE(PSATEMP,"^")
- SET PSAREORD=+$PIECE(PSATEMP,"^",2)
- SET PSASUB=+$PIECE(PSATEMP,"^",3)
- SET PSASTOCK=+$PIECE(PSATEMP,"^",4)
- +2 SET PSADUOU=$SELECT(+PSADUOU:+PSADUOU,+PSASUB&(+$PIECE($GET(^PSDRUG(PSADRG,1,PSASUB,0)),"^",7)):+$PIECE($GET(^PSDRUG(PSADRG,1,PSASUB,0)),"^",7),1:1)
- +3 SET PSADUREC=$SELECT(PSADUOU:PSAQTY*PSADUOU,1:0)
- +4 ;
- +5 ;DAVE B (18NOV98)
- +6 ;I PSADUREC=0,$D(PSAQTY),$P($G(^PSDRUG(PSADRG,660)),"^",5)'="" S PSADUREC=(PSAQTY*($P(^PSDRUG(PSADRG,660),"^",5)))
- +7 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:0)
- +8 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:0)
- +9 SET ITM(.01)=PSALINE
- SET ITM(1)=PSADRG
- SET ITM(2)=PSAQTY
- SET ITM(3)=PSAOU
- SET ITM(4)=PSANPOU
- SET ITM(13)=PSANDC
- SET ITM(10)=PSADUOU
- +10 SET IENS=PSALINE_","_PSAIEN1_","_PSAIEN
- +11 FOR X=5,6,7,8,12,14,15,16,17
- SET ITM(X)=$$GET1^DIQ(58.81125,IENS,X,FORM)
- +12 ;also handle supply items ITM(1)=supply item name
- IF FORM'="I"
- SET ITM(3)=$$GET1^DIQ(51.5,ITM(3),.01)
- if +ITM(1)=ITM(1)
- SET ITM(1)=$$GET1^DIQ(50,ITM(1),.01)
- +13 QUIT