PSS51P5 ;BIR/LDT - API FOR INFORMATION FROM FILE 51.5; 5 Sep 03
;;1.0;PHARMACY DATA MANAGEMENT;**85**;9/30/97
;External reference to DD(51.5,0,"IX" supported by DBIA 4326
;
ALL(PSSIEN,PSSFT,PSSCRFL,LIST) ;
;PSSIEN - IEN of entry in the ORDER UNIT file (#51.5).
;PSSFT - Free Text name in the ORDER UNIT file (#51.5).
;PSSCRFL - Multiple index lookup is performed if passed in a 1.
; Otherwise only the "B" cross-reference is used.
;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is the
; Field Number of the data piece being returned.
;Returns ABBREVIATION field (#.01) and EXPANSION field (#.02) of ORDER UNIT file (#51.5).
N DIERR,ZZERR,PSS51P5,PSS,INDX,PSSISUB,PSSISUBX,PSSLUPP,PSSLUPAR,PSSCNT51
S PSSCNT51=0
S INDX="B"
I $G(LIST)']"" Q
K ^TMP($J,LIST)
I +$G(PSSIEN)'>0,($G(PSSFT)']"") S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
I $G(PSSIEN)]"",+$G(PSSIEN)'>0 S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
I +$G(PSSIEN)>0 N PSSIEN2 S PSSIEN2=$$FIND1^DIC(51.5,"","A","`"_PSSIEN,,,"") D
.I +PSSIEN2'>0 Q
.S PSSCNT51=PSSCNT51+1
.D GETS^DIQ(51.5,+PSSIEN2,".01;.02","I","PSS51P5") S PSS(1)=0
.F S PSS(1)=$O(PSS51P5(51.5,PSS(1))) Q:'PSS(1) D SETZRO
I +$G(PSSIEN)'>0,$G(PSSFT)]"" D
.I PSSFT["??" D LOOP Q
.I $G(PSSCRFL)=1 S (PSSISUB,PSSISUBX)="" F S PSSISUB=$O(^DD(51.5,0,"IX",PSSISUB)) Q:PSSISUB="" D
..I $G(PSSISUBX)="" S PSSISUBX=PSSISUB Q
..S PSSISUBX=PSSISUBX_"^"_PSSISUB
.I $G(PSSCRFL)'=1 S PSSISUBX="B"
.K ^TMP($J,"PSSLDONE")
.D PARSE(PSSISUBX) I '$O(PSSLUPAR(0)) S PSSLUPAR(1)="B"
.S PSSLUPP=0 F S PSSLUPP=$O(PSSLUPAR(PSSLUPP)) Q:'PSSLUPP D
..K ^TMP("DILIST",$J)
..D FIND^DIC(51.5,,"@;.01","QPB"_$S($P(PSSLUPAR(PSSLUPP),"^",2):"X",1:""),PSSFT,,PSSLUPAR(PSSLUPP),,,"")
..I +$G(^TMP("DILIST",$J,0))=0 Q
..N PSSXX S PSSXX=0 F S PSSXX=$O(^TMP("DILIST",$J,PSSXX)) Q:'PSSXX D
...S PSSIEN=+^TMP("DILIST",$J,PSSXX,0) I '$D(^TMP($J,"PSSLDONE",PSSIEN)) S ^TMP($J,"PSSLDONE",PSSIEN)="" K PSS51P5 S PSSCNT51=PSSCNT51+1 D GETS^DIQ(51.5,+PSSIEN,".01;.02","I","PSS51P5") S PSS(1)=0 D
....F S PSS(1)=$O(PSS51P5(51.5,PSS(1))) Q:'PSS(1) D SETZRO
S ^TMP($J,LIST,0)=$S($G(PSSCNT51):$G(PSSCNT51),1:"-1^NO DATA FOUND")
K ^TMP("DILIST",$J),^TMP($J,"PSSLDONE")
Q
;
EXPAN(PSSEXPAN,LIST) ;
;PSSEXPAN - EXPANSION field (#.02) of the ORDER UNIT file (#51.5).
;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is the
; Field Number of the data piece being returned.
;Returns ABBREVIATION field (#.01) and EXPANSION field (#.02) of ORDER UNIT file (#51.5).
N DIERR,ZZERR,PSS51P5,PSS,INDX
S INDX="C"
I $G(LIST)']"" Q
K ^TMP($J,LIST)
I $G(PSSEXPAN)']"" S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
D FIND^DIC(51.5,,"@;.01;.02","QP",PSSEXPAN,,"C",,,"")
I +$G(^TMP("DILIST",$J,0))=0 S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
S ^TMP($J,LIST,0)=+^TMP("DILIST",$J,0) N PSSXX S PSSXX=0 F S PSSXX=$O(^TMP("DILIST",$J,PSSXX)) Q:'PSSXX D
.S PSSIEN=+^TMP("DILIST",$J,PSSXX,0) K PSS51P5 D GETS^DIQ(51.5,+PSSIEN,".01;.02","I","PSS51P5") S PSS(1)=0
.F S PSS(1)=$O(PSS51P5(51.5,PSS(1))) Q:'PSS(1) D SETZRO
K ^TMP("DILIST",$J)
Q
;
SETZRO ;
S ^TMP($J,LIST,+PSS(1),.01)=$G(PSS51P5(51.5,PSS(1),.01,"I"))
S ^TMP($J,LIST,INDX,$G(PSS51P5(51.5,PSS(1),.01,"I")),+PSS(1))=""
S ^TMP($J,LIST,+PSS(1),.02)=$G(PSS51P5(51.5,PSS(1),.02,"I"))
Q
;
LOOP ;
N INDX S INDX="B"
S PSSIEN=0,^TMP($J,LIST,0)=0 F S PSSIEN=$O(^DIC(51.5,PSSIEN)) Q:'PSSIEN D
.S PSSCNT51=PSSCNT51+1
.K PSS51P5 D GETS^DIQ(51.5,+PSSIEN,".01;.02","I","PSS51P5") S PSS(1)=0 D
..F S PSS(1)=$O(PSS51P5(51.5,PSS(1))) Q:'PSS(1) D SETZRO
K ^TMP("DILIST",$J)
Q
PARSE(PSSLUP) ; Create array of cross references, piece 2 of the array =1 for pointer fields, else 0
I $G(PSSLUP)="" Q
N PSSLUPA,PSSLUP1,PSSLUP2,PSSLUP3,PSSLUP4,PSSLUP5,PSSDTYPE,PSSPTER
I $E(PSSLUP)="^" S PSSLUP=$E(PSSLUP,2,$L(PSSLUP))
S PSSLUP1=0 F PSSLUP2=1:1:$L(PSSLUP) I $E(PSSLUP,PSSLUP2)="^" S PSSLUP1=PSSLUP1+1
S PSSLUP1=PSSLUP1+1
S PSSLUP4=1 F PSSLUP3=1:1:PSSLUP1 S PSSLUP5=$P(PSSLUP,"^",PSSLUP3) I PSSLUP5'="" D S PSSLUPAR(PSSLUP4)=PSSLUP5_"^"_$G(PSSPTER),PSSLUP4=PSSLUP4+1
.N PSSCRX,PSSCRX1 S PSSPTER=0
.S PSSCRX="" F S PSSCRX=$O(^DD(51.5,0,"IX",PSSLUP5,PSSCRX)) Q:PSSCRX="" S PSSCRX1="" F S PSSCRX1=$O(^DD(51.5,0,"IX",PSSLUP5,PSSCRX,PSSCRX1)) Q:PSSCRX1="" D
..K PSSDTYPE D FIELD^DID(PSSCRX,PSSCRX1,,"TYPE","PSSDTYPE") I $G(PSSDTYPE("TYPE"))="POINTER" S PSSPTER=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSS51P5 4527 printed Dec 13, 2024@02:30:09 Page 2
PSS51P5 ;BIR/LDT - API FOR INFORMATION FROM FILE 51.5; 5 Sep 03
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**85**;9/30/97
+2 ;External reference to DD(51.5,0,"IX" supported by DBIA 4326
+3 ;
ALL(PSSIEN,PSSFT,PSSCRFL,LIST) ;
+1 ;PSSIEN - IEN of entry in the ORDER UNIT file (#51.5).
+2 ;PSSFT - Free Text name in the ORDER UNIT file (#51.5).
+3 ;PSSCRFL - Multiple index lookup is performed if passed in a 1.
+4 ; Otherwise only the "B" cross-reference is used.
+5 ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is the
+6 ; Field Number of the data piece being returned.
+7 ;Returns ABBREVIATION field (#.01) and EXPANSION field (#.02) of ORDER UNIT file (#51.5).
+8 NEW DIERR,ZZERR,PSS51P5,PSS,INDX,PSSISUB,PSSISUBX,PSSLUPP,PSSLUPAR,PSSCNT51
+9 SET PSSCNT51=0
+10 SET INDX="B"
+11 IF $GET(LIST)']""
QUIT
+12 KILL ^TMP($JOB,LIST)
+13 IF +$GET(PSSIEN)'>0
IF ($GET(PSSFT)']"")
SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
QUIT
+14 IF $GET(PSSIEN)]""
IF +$GET(PSSIEN)'>0
SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
QUIT
+15 IF +$GET(PSSIEN)>0
NEW PSSIEN2
SET PSSIEN2=$$FIND1^DIC(51.5,"","A","`"_PSSIEN,,,"")
Begin DoDot:1
+16 IF +PSSIEN2'>0
QUIT
+17 SET PSSCNT51=PSSCNT51+1
+18 DO GETS^DIQ(51.5,+PSSIEN2,".01;.02","I","PSS51P5")
SET PSS(1)=0
+19 FOR
SET PSS(1)=$ORDER(PSS51P5(51.5,PSS(1)))
if 'PSS(1)
QUIT
DO SETZRO
End DoDot:1
+20 IF +$GET(PSSIEN)'>0
IF $GET(PSSFT)]""
Begin DoDot:1
+21 IF PSSFT["??"
DO LOOP
QUIT
+22 IF $GET(PSSCRFL)=1
SET (PSSISUB,PSSISUBX)=""
FOR
SET PSSISUB=$ORDER(^DD(51.5,0,"IX",PSSISUB))
if PSSISUB=""
QUIT
Begin DoDot:2
+23 IF $GET(PSSISUBX)=""
SET PSSISUBX=PSSISUB
QUIT
+24 SET PSSISUBX=PSSISUBX_"^"_PSSISUB
End DoDot:2
+25 IF $GET(PSSCRFL)'=1
SET PSSISUBX="B"
+26 KILL ^TMP($JOB,"PSSLDONE")
+27 DO PARSE(PSSISUBX)
IF '$ORDER(PSSLUPAR(0))
SET PSSLUPAR(1)="B"
+28 SET PSSLUPP=0
FOR
SET PSSLUPP=$ORDER(PSSLUPAR(PSSLUPP))
if 'PSSLUPP
QUIT
Begin DoDot:2
+29 KILL ^TMP("DILIST",$JOB)
+30 DO FIND^DIC(51.5,,"@;.01","QPB"_$SELECT($PIECE(PSSLUPAR(PSSLUPP),"^",2):"X",1:""),PSSFT,,PSSLUPAR(PSSLUPP),,,"")
+31 IF +$GET(^TMP("DILIST",$JOB,0))=0
QUIT
+32 NEW PSSXX
SET PSSXX=0
FOR
SET PSSXX=$ORDER(^TMP("DILIST",$JOB,PSSXX))
if 'PSSXX
QUIT
Begin DoDot:3
+33 SET PSSIEN=+^TMP("DILIST",$JOB,PSSXX,0)
IF '$DATA(^TMP($JOB,"PSSLDONE",PSSIEN))
SET ^TMP($JOB,"PSSLDONE",PSSIEN)=""
KILL PSS51P5
SET PSSCNT51=PSSCNT51+1
DO GETS^DIQ(51.5,+PSSIEN,".01;.02","I","PSS51P5")
SET PSS(1)=0
Begin DoDot:4
+34 FOR
SET PSS(1)=$ORDER(PSS51P5(51.5,PSS(1)))
if 'PSS(1)
QUIT
DO SETZRO
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+35 SET ^TMP($JOB,LIST,0)=$SELECT($GET(PSSCNT51):$GET(PSSCNT51),1:"-1^NO DATA FOUND")
+36 KILL ^TMP("DILIST",$JOB),^TMP($JOB,"PSSLDONE")
+37 QUIT
+38 ;
EXPAN(PSSEXPAN,LIST) ;
+1 ;PSSEXPAN - EXPANSION field (#.02) of the ORDER UNIT file (#51.5).
+2 ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is the
+3 ; Field Number of the data piece being returned.
+4 ;Returns ABBREVIATION field (#.01) and EXPANSION field (#.02) of ORDER UNIT file (#51.5).
+5 NEW DIERR,ZZERR,PSS51P5,PSS,INDX
+6 SET INDX="C"
+7 IF $GET(LIST)']""
QUIT
+8 KILL ^TMP($JOB,LIST)
+9 IF $GET(PSSEXPAN)']""
SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
QUIT
+10 DO FIND^DIC(51.5,,"@;.01;.02","QP",PSSEXPAN,,"C",,,"")
+11 IF +$GET(^TMP("DILIST",$JOB,0))=0
SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
QUIT
+12 SET ^TMP($JOB,LIST,0)=+^TMP("DILIST",$JOB,0)
NEW PSSXX
SET PSSXX=0
FOR
SET PSSXX=$ORDER(^TMP("DILIST",$JOB,PSSXX))
if 'PSSXX
QUIT
Begin DoDot:1
+13 SET PSSIEN=+^TMP("DILIST",$JOB,PSSXX,0)
KILL PSS51P5
DO GETS^DIQ(51.5,+PSSIEN,".01;.02","I","PSS51P5")
SET PSS(1)=0
+14 FOR
SET PSS(1)=$ORDER(PSS51P5(51.5,PSS(1)))
if 'PSS(1)
QUIT
DO SETZRO
End DoDot:1
+15 KILL ^TMP("DILIST",$JOB)
+16 QUIT
+17 ;
SETZRO ;
+1 SET ^TMP($JOB,LIST,+PSS(1),.01)=$GET(PSS51P5(51.5,PSS(1),.01,"I"))
+2 SET ^TMP($JOB,LIST,INDX,$GET(PSS51P5(51.5,PSS(1),.01,"I")),+PSS(1))=""
+3 SET ^TMP($JOB,LIST,+PSS(1),.02)=$GET(PSS51P5(51.5,PSS(1),.02,"I"))
+4 QUIT
+5 ;
LOOP ;
+1 NEW INDX
SET INDX="B"
+2 SET PSSIEN=0
SET ^TMP($JOB,LIST,0)=0
FOR
SET PSSIEN=$ORDER(^DIC(51.5,PSSIEN))
if 'PSSIEN
QUIT
Begin DoDot:1
+3 SET PSSCNT51=PSSCNT51+1
+4 KILL PSS51P5
DO GETS^DIQ(51.5,+PSSIEN,".01;.02","I","PSS51P5")
SET PSS(1)=0
Begin DoDot:2
+5 FOR
SET PSS(1)=$ORDER(PSS51P5(51.5,PSS(1)))
if 'PSS(1)
QUIT
DO SETZRO
End DoDot:2
End DoDot:1
+6 KILL ^TMP("DILIST",$JOB)
+7 QUIT
PARSE(PSSLUP) ; Create array of cross references, piece 2 of the array =1 for pointer fields, else 0
+1 IF $GET(PSSLUP)=""
QUIT
+2 NEW PSSLUPA,PSSLUP1,PSSLUP2,PSSLUP3,PSSLUP4,PSSLUP5,PSSDTYPE,PSSPTER
+3 IF $EXTRACT(PSSLUP)="^"
SET PSSLUP=$EXTRACT(PSSLUP,2,$LENGTH(PSSLUP))
+4 SET PSSLUP1=0
FOR PSSLUP2=1:1:$LENGTH(PSSLUP)
IF $EXTRACT(PSSLUP,PSSLUP2)="^"
SET PSSLUP1=PSSLUP1+1
+5 SET PSSLUP1=PSSLUP1+1
+6 SET PSSLUP4=1
FOR PSSLUP3=1:1:PSSLUP1
SET PSSLUP5=$PIECE(PSSLUP,"^",PSSLUP3)
IF PSSLUP5'=""
Begin DoDot:1
+7 NEW PSSCRX,PSSCRX1
SET PSSPTER=0
+8 SET PSSCRX=""
FOR
SET PSSCRX=$ORDER(^DD(51.5,0,"IX",PSSLUP5,PSSCRX))
if PSSCRX=""
QUIT
SET PSSCRX1=""
FOR
SET PSSCRX1=$ORDER(^DD(51.5,0,"IX",PSSLUP5,PSSCRX,PSSCRX1))
if PSSCRX1=""
QUIT
Begin DoDot:2
+9 KILL PSSDTYPE
DO FIELD^DID(PSSCRX,PSSCRX1,,"TYPE","PSSDTYPE")
IF $GET(PSSDTYPE("TYPE"))="POINTER"
SET PSSPTER=1
End DoDot:2
End DoDot:1
SET PSSLUPAR(PSSLUP4)=PSSLUP5_"^"_$GET(PSSPTER)
SET PSSLUP4=PSSLUP4+1
+10 QUIT
