- 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 Apr 23, 2025@18:44:10 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
