PSS50B ;BIR/LDT - API FOR INFORMATION FROM FILE 50; 5 Sep 03
;;1.0;PHARMACY DATA MANAGEMENT;**85**;9/30/97
;
INV ;
;PSSIEN - IEN of entry in 50
;PSSFT - Free Text name in 50
;PSSFL - Inactive flag - "" - All entries
; FileMan Date - Only entries with no Inactive Date or an Inactive Date greater than this date.
;PSSPK - Application Package's Use - "" - All entries
; Alphabetic codes that represent the DHCP packages that consider this drug to be
; part of their formulary.
;PSSRTOI - Orderable Item - return only entries matched to a Pharmacy Orderable Item
;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.
N DIERR,ZZERR,SCR,PSS,PSSMLCT,PSSP50
I $G(LIST)']"" Q
K ^TMP($J,LIST)
I +$G(PSSIEN)'>0,($G(PSSFT)']"") S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
S SCR("S")=""
I +$G(PSSFL)>0!($G(PSSPK)]"")!($G(PSSRTOI)=1) N PSS5ND,PSSZ3,PSSZ4 D SETSCRN^PSS50A
I +$G(PSSIEN)>0 N PSSIEN2 S PSSIEN2=$$FIND1^DIC(50,"","A","`"_PSSIEN,,SCR("S"),"") D K ^TMP("PSSP50",$J) Q
.K ^TMP("DIERR",$J)
.I +PSSIEN2'>0 S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
.S ^TMP($J,LIST,0)=1
.D SETSUB1^PSS50AQM(+PSSIEN2),SETSUB4^PSS50AQM(+PSSIEN2)
.K ^TMP("PSSP50",$J) D GETS^DIQ(50,+PSSIEN2,".01;9*;11:17.1;50;441*","IE","^TMP(""PSSP50"",$J)") S PSS(1)=0
.F S PSS(1)=$O(^TMP("PSSP50",$J,50,PSS(1))) Q:'PSS(1) D SETINV^PSS50ATC D
..S (PSS(2),PSSMLCT)=0 F S PSS(2)=$O(^TMP("PSSP50",$J,50.1,PSS(2))) Q:'PSS(2) S PSSMLCT=PSSMLCT+1 D SETSYN2^PSS50ATC
..S ^TMP($J,LIST,+PSS(1),"SYN",0)=$S($G(PSSMLCT):PSSMLCT,1:"-1^NO DATA FOUND")
..S (PSS(2),PSSMLCT)=0 F S PSS(2)=$O(^TMP("PSSP50",$J,50.0441,PSS(2))) Q:'PSS(2) S PSSMLCT=PSSMLCT+1 D SETIFC^PSS50ATC
..S ^TMP($J,LIST,+PSS(1),"IFC",0)=$S($G(PSSMLCT):PSSMLCT,1:"-1^NO DATA FOUND")
I $G(PSSIEN)'="" S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
I $G(PSSFT)]"" D
.I PSSFT["??" D LOOP^PSS50B1 Q
.K ^TMP("DILIST",$J)
.D FIND^DIC(50,,"@;.01","QP",PSSFT,,"B",SCR("S"),,"")
.I +$G(^TMP("DILIST",$J,0))=0 S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
.I +^TMP("DILIST",$J,0)>0 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)
..D SETSUB1^PSS50AQM(PSSIEN),SETSUB4^PSS50AQM(PSSIEN) K ^TMP("PSSP50",$J) D GETS^DIQ(50,+PSSIEN,".01;9*;11:17.1;50;441*","IE","^TMP(""PSSP50"",$J)") S PSS(1)=0
..F S PSS(1)=$O(^TMP("PSSP50",$J,50,PSS(1))) Q:'PSS(1) D SETINV^PSS50ATC D
...S (PSS(2),PSSMLCT)=0 F S PSS(2)=$O(^TMP("PSSP50",$J,50.1,PSS(2))) Q:'PSS(2) S PSSMLCT=PSSMLCT+1 D SETSYN2^PSS50ATC
...S ^TMP($J,LIST,+PSS(1),"SYN",0)=$S($G(PSSMLCT):PSSMLCT,1:"-1^NO DATA FOUND")
...S (PSS(2),PSSMLCT)=0 F S PSS(2)=$O(^TMP("PSSP50",$J,50.0441,PSS(2))) Q:'PSS(2) S PSSMLCT=PSSMLCT+1 D SETIFC^PSS50ATC
...S ^TMP($J,LIST,+PSS(1),"IFC",0)=$S($G(PSSMLCT):PSSMLCT,1:"-1^NO DATA FOUND")
K ^TMP("DILIST",$J),^TMP("PSSP50",$J)
Q
;
NDF ;
;PSSIEN - IEN of entry in 50
;PSSFT - Free Text name in 50
;PSSFL - Inactive flag - "" - All entries
; FileMan Date - Only entries with no Inactive Date or an Inactive Date greater than this date.
;PSSPK - Application Package's Use - "" - All entries
; Alphabetic codes that represent the DHCP packages that consider this drug to be
; part of their formulary.
;;PSSRTOI - Orderable Item - return only entries matched to a Pharmacy Orderable Item
;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.
N DIERR,ZZERR,PSSP50,SCR,PSS,PSSMLCT
I $G(LIST)']"" Q
K ^TMP($J,LIST)
I +$G(PSSIEN)'>0,($G(PSSFT)']"") S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
S SCR("S")=""
I +$G(PSSFL)>0!($G(PSSPK)]"")!($G(PSSRTOI)=1) N PSS5ND,PSSZ3,PSSZ4 D SETSCRN^PSS50A
I +$G(PSSIEN)>0 N PSSIEN2 S PSSIEN2=$$FIND1^DIC(50,"","A","`"_PSSIEN,,SCR("S"),"") D K ^TMP("PSSP50",$J) Q
.K ^TMP("DIERR",$J)
.I +PSSIEN2'>0 S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
.S ^TMP($J,LIST,0)=1
.K ^TMP("PSSP50",$J) D GETS^DIQ(50,+PSSIEN2,".01;20:25;27;29","IE","^TMP(""PSSP50"",$J)") S PSS(1)=0
.F S PSS(1)=$O(^TMP("PSSP50",$J,50,PSS(1))) Q:'PSS(1) D SETND^PSS50NDF
I $G(PSSIEN)'="" S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
I $G(PSSFT)]"" D
.I PSSFT["??" D LOOP^PSS50NDF Q
.K ^TMP("DILIST",$J)
.D FIND^DIC(50,,"@;.01","QP",PSSFT,,"B",SCR("S"),,"")
.I +$G(^TMP("DILIST",$J,0))=0 S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
.I +^TMP("DILIST",$J,0)>0 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 ^TMP("PSSP50",$J) D GETS^DIQ(50,+PSSIEN,".01;20:25;27;29","IE","^TMP(""PSSP50"",$J)") S PSS(1)=0
..F S PSS(1)=$O(^TMP("PSSP50",$J,50,PSS(1))) Q:'PSS(1) D SETND^PSS50NDF
K ^TMP("DILIST",$J),^TMP("PSSP50",$J)
Q
;
DOSE ;
;PSSIEN - IEN of entry in 50
;PSSFT - Free Text name in 50
;PSSFL - Inactive flag - "" - All entries
; FileMan Date - Only entries with no Inactive Date or an Inactive Date greater than this date.
;PSSPK - Application Package's Use - "" - All entries
; Alphabetic codes that represent the DHCP packages that consider this drug to be
; part of their formulary.
;PSSRTOI - Orderable Item - return only entries matched to a Pharmacy Orderable Item
;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.
N DIERR,ZZERR,PSSP50,SCR,PSSMLCT,PSS
I $G(LIST)']"" Q
K ^TMP($J,LIST)
I +$G(PSSIEN)'>0,($G(PSSFT)']"") S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
S SCR("S")=""
I +$G(PSSFL)>0!($G(PSSPK)]"")!($G(PSSRTOI)=1) N PSS5ND,PSSZ3,PSSZ4 D SETSCRN^PSS50A
I +$G(PSSIEN)>0 N PSSIEN2 S PSSIEN2=$$FIND1^DIC(50,"","A","`"_PSSIEN,,SCR("S"),"") D K ^TMP("PSSP50",$J) Q
.K ^TMP("DIERR",$J)
.I +PSSIEN2'>0 S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
.S ^TMP($J,LIST,0)=1
.D SETSUB7^PSS50AQM(+PSSIEN2),SETSUB8^PSS50AQM(+PSSIEN2)
.K ^TMP("PSSP50",$J) D GETS^DIQ(50,+PSSIEN2,".01;901;902;903*;904*","IE","^TMP(""PSSP50"",$J)") S PSS(1)=0
.F S PSS(1)=$O(^TMP("PSSP50",$J,50,PSS(1))) Q:'PSS(1) D SDOSE^PSS50DOS D
..S (PSS(2),PSSMLCT)=0 F S PSS(2)=$O(^TMP("PSSP50",$J,50.0903,PSS(2))) Q:'PSS(2) S PSSMLCT=PSSMLCT+1 D SDOSE2^PSS50DOS
..S ^TMP($J,LIST,+PSS(1),"POS",0)=$S($G(PSSMLCT):PSSMLCT,1:"-1^NO DATA FOUND")
..S (PSS(2),PSSMLCT)=0 F S PSS(2)=$O(^TMP("PSSP50",$J,50.0904,PSS(2))) Q:'PSS(2) S PSSMLCT=PSSMLCT+1 D SDOSE3^PSS50DOS
..S ^TMP($J,LIST,+PSS(1),"LOC",0)=$S($G(PSSMLCT):PSSMLCT,1:"-1^NO DATA FOUND")
I $G(PSSIEN)'="" S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
I $G(PSSFT)]"" D
.I PSSFT["??" D LOOP^PSS50DOS Q
.K ^TMP("DILIST",$J)
.D FIND^DIC(50,,"@;.01","QP",PSSFT,,"B",SCR("S"),,"")
.I +$G(^TMP("DILIST",$J,0))=0 S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
.I +^TMP("DILIST",$J,0)>0 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)
..D SETSUB7^PSS50AQM(PSSIEN),SETSUB8^PSS50AQM(PSSIEN) K ^TMP("PSSP50",$J) D GETS^DIQ(50,+PSSIEN,".01;901;902;903*;904*","IE","^TMP(""PSSP50"",$J)") S PSS(1)=0
..F S PSS(1)=$O(^TMP("PSSP50",$J,50,PSS(1))) Q:'PSS(1) D SDOSE^PSS50DOS D
...S (PSS(2),PSSMLCT)=0 F S PSS(2)=$O(^TMP("PSSP50",$J,50.0903,PSS(2))) Q:'PSS(2) S PSSMLCT=PSSMLCT+1 D SDOSE2^PSS50DOS
...S ^TMP($J,LIST,+PSS(1),"POS",0)=$S($G(PSSMLCT):PSSMLCT,1:"-1^NO DATA FOUND")
...S (PSS(2),PSSMLCT)=0 F S PSS(2)=$O(^TMP("PSSP50",$J,50.0904,PSS(2))) Q:'PSS(2) S PSSMLCT=PSSMLCT+1 D SDOSE3^PSS50DOS
...S ^TMP($J,LIST,+PSS(1),"LOC",0)=$S($G(PSSMLCT):PSSMLCT,1:"-1^NO DATA FOUND")
K ^TMP("DILIST",$J),^TMP("PSSP50",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSS50B 8228 printed Apr 09, 2024@21:32:43 Page 2
PSS50B ;BIR/LDT - API FOR INFORMATION FROM FILE 50; 5 Sep 03
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**85**;9/30/97
+2 ;
INV ;
+1 ;PSSIEN - IEN of entry in 50
+2 ;PSSFT - Free Text name in 50
+3 ;PSSFL - Inactive flag - "" - All entries
+4 ; FileMan Date - Only entries with no Inactive Date or an Inactive Date greater than this date.
+5 ;PSSPK - Application Package's Use - "" - All entries
+6 ; Alphabetic codes that represent the DHCP packages that consider this drug to be
+7 ; part of their formulary.
+8 ;PSSRTOI - Orderable Item - return only entries matched to a Pharmacy Orderable Item
+9 ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is the Field Number of the data
+10 ; piece being returned.
+11 NEW DIERR,ZZERR,SCR,PSS,PSSMLCT,PSSP50
+12 IF $GET(LIST)']""
QUIT
+13 KILL ^TMP($JOB,LIST)
+14 IF +$GET(PSSIEN)'>0
IF ($GET(PSSFT)']"")
SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
QUIT
+15 SET SCR("S")=""
+16 IF +$GET(PSSFL)>0!($GET(PSSPK)]"")!($GET(PSSRTOI)=1)
NEW PSS5ND,PSSZ3,PSSZ4
DO SETSCRN^PSS50A
+17 IF +$GET(PSSIEN)>0
NEW PSSIEN2
SET PSSIEN2=$$FIND1^DIC(50,"","A","`"_PSSIEN,,SCR("S"),"")
Begin DoDot:1
+18 KILL ^TMP("DIERR",$JOB)
+19 IF +PSSIEN2'>0
SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
QUIT
+20 SET ^TMP($JOB,LIST,0)=1
+21 DO SETSUB1^PSS50AQM(+PSSIEN2)
DO SETSUB4^PSS50AQM(+PSSIEN2)
+22 KILL ^TMP("PSSP50",$JOB)
DO GETS^DIQ(50,+PSSIEN2,".01;9*;11:17.1;50;441*","IE","^TMP(""PSSP50"",$J)")
SET PSS(1)=0
+23 FOR
SET PSS(1)=$ORDER(^TMP("PSSP50",$JOB,50,PSS(1)))
if 'PSS(1)
QUIT
DO SETINV^PSS50ATC
Begin DoDot:2
+24 SET (PSS(2),PSSMLCT)=0
FOR
SET PSS(2)=$ORDER(^TMP("PSSP50",$JOB,50.1,PSS(2)))
if 'PSS(2)
QUIT
SET PSSMLCT=PSSMLCT+1
DO SETSYN2^PSS50ATC
+25 SET ^TMP($JOB,LIST,+PSS(1),"SYN",0)=$SELECT($GET(PSSMLCT):PSSMLCT,1:"-1^NO DATA FOUND")
+26 SET (PSS(2),PSSMLCT)=0
FOR
SET PSS(2)=$ORDER(^TMP("PSSP50",$JOB,50.0441,PSS(2)))
if 'PSS(2)
QUIT
SET PSSMLCT=PSSMLCT+1
DO SETIFC^PSS50ATC
+27 SET ^TMP($JOB,LIST,+PSS(1),"IFC",0)=$SELECT($GET(PSSMLCT):PSSMLCT,1:"-1^NO DATA FOUND")
End DoDot:2
End DoDot:1
KILL ^TMP("PSSP50",$JOB)
QUIT
+28 IF $GET(PSSIEN)'=""
SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
QUIT
+29 IF $GET(PSSFT)]""
Begin DoDot:1
+30 IF PSSFT["??"
DO LOOP^PSS50B1
QUIT
+31 KILL ^TMP("DILIST",$JOB)
+32 DO FIND^DIC(50,,"@;.01","QP",PSSFT,,"B",SCR("S"),,"")
+33 IF +$GET(^TMP("DILIST",$JOB,0))=0
SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
QUIT
+34 IF +^TMP("DILIST",$JOB,0)>0
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:2
+35 SET PSSIEN=+^TMP("DILIST",$JOB,PSSXX,0)
+36 DO SETSUB1^PSS50AQM(PSSIEN)
DO SETSUB4^PSS50AQM(PSSIEN)
KILL ^TMP("PSSP50",$JOB)
DO GETS^DIQ(50,+PSSIEN,".01;9*;11:17.1;50;441*","IE","^TMP(""PSSP50"",$J)")
SET PSS(1)=0
+37 FOR
SET PSS(1)=$ORDER(^TMP("PSSP50",$JOB,50,PSS(1)))
if 'PSS(1)
QUIT
DO SETINV^PSS50ATC
Begin DoDot:3
+38 SET (PSS(2),PSSMLCT)=0
FOR
SET PSS(2)=$ORDER(^TMP("PSSP50",$JOB,50.1,PSS(2)))
if 'PSS(2)
QUIT
SET PSSMLCT=PSSMLCT+1
DO SETSYN2^PSS50ATC
+39 SET ^TMP($JOB,LIST,+PSS(1),"SYN",0)=$SELECT($GET(PSSMLCT):PSSMLCT,1:"-1^NO DATA FOUND")
+40 SET (PSS(2),PSSMLCT)=0
FOR
SET PSS(2)=$ORDER(^TMP("PSSP50",$JOB,50.0441,PSS(2)))
if 'PSS(2)
QUIT
SET PSSMLCT=PSSMLCT+1
DO SETIFC^PSS50ATC
+41 SET ^TMP($JOB,LIST,+PSS(1),"IFC",0)=$SELECT($GET(PSSMLCT):PSSMLCT,1:"-1^NO DATA FOUND")
End DoDot:3
End DoDot:2
End DoDot:1
+42 KILL ^TMP("DILIST",$JOB),^TMP("PSSP50",$JOB)
+43 QUIT
+44 ;
NDF ;
+1 ;PSSIEN - IEN of entry in 50
+2 ;PSSFT - Free Text name in 50
+3 ;PSSFL - Inactive flag - "" - All entries
+4 ; FileMan Date - Only entries with no Inactive Date or an Inactive Date greater than this date.
+5 ;PSSPK - Application Package's Use - "" - All entries
+6 ; Alphabetic codes that represent the DHCP packages that consider this drug to be
+7 ; part of their formulary.
+8 ;;PSSRTOI - Orderable Item - return only entries matched to a Pharmacy Orderable Item
+9 ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is the Field Number of the data
+10 ; piece being returned.
+11 NEW DIERR,ZZERR,PSSP50,SCR,PSS,PSSMLCT
+12 IF $GET(LIST)']""
QUIT
+13 KILL ^TMP($JOB,LIST)
+14 IF +$GET(PSSIEN)'>0
IF ($GET(PSSFT)']"")
SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
QUIT
+15 SET SCR("S")=""
+16 IF +$GET(PSSFL)>0!($GET(PSSPK)]"")!($GET(PSSRTOI)=1)
NEW PSS5ND,PSSZ3,PSSZ4
DO SETSCRN^PSS50A
+17 IF +$GET(PSSIEN)>0
NEW PSSIEN2
SET PSSIEN2=$$FIND1^DIC(50,"","A","`"_PSSIEN,,SCR("S"),"")
Begin DoDot:1
+18 KILL ^TMP("DIERR",$JOB)
+19 IF +PSSIEN2'>0
SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
QUIT
+20 SET ^TMP($JOB,LIST,0)=1
+21 KILL ^TMP("PSSP50",$JOB)
DO GETS^DIQ(50,+PSSIEN2,".01;20:25;27;29","IE","^TMP(""PSSP50"",$J)")
SET PSS(1)=0
+22 FOR
SET PSS(1)=$ORDER(^TMP("PSSP50",$JOB,50,PSS(1)))
if 'PSS(1)
QUIT
DO SETND^PSS50NDF
End DoDot:1
KILL ^TMP("PSSP50",$JOB)
QUIT
+23 IF $GET(PSSIEN)'=""
SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
QUIT
+24 IF $GET(PSSFT)]""
Begin DoDot:1
+25 IF PSSFT["??"
DO LOOP^PSS50NDF
QUIT
+26 KILL ^TMP("DILIST",$JOB)
+27 DO FIND^DIC(50,,"@;.01","QP",PSSFT,,"B",SCR("S"),,"")
+28 IF +$GET(^TMP("DILIST",$JOB,0))=0
SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
QUIT
+29 IF +^TMP("DILIST",$JOB,0)>0
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:2
+30 SET PSSIEN=+^TMP("DILIST",$JOB,PSSXX,0)
+31 KILL ^TMP("PSSP50",$JOB)
DO GETS^DIQ(50,+PSSIEN,".01;20:25;27;29","IE","^TMP(""PSSP50"",$J)")
SET PSS(1)=0
+32 FOR
SET PSS(1)=$ORDER(^TMP("PSSP50",$JOB,50,PSS(1)))
if 'PSS(1)
QUIT
DO SETND^PSS50NDF
End DoDot:2
End DoDot:1
+33 KILL ^TMP("DILIST",$JOB),^TMP("PSSP50",$JOB)
+34 QUIT
+35 ;
DOSE ;
+1 ;PSSIEN - IEN of entry in 50
+2 ;PSSFT - Free Text name in 50
+3 ;PSSFL - Inactive flag - "" - All entries
+4 ; FileMan Date - Only entries with no Inactive Date or an Inactive Date greater than this date.
+5 ;PSSPK - Application Package's Use - "" - All entries
+6 ; Alphabetic codes that represent the DHCP packages that consider this drug to be
+7 ; part of their formulary.
+8 ;PSSRTOI - Orderable Item - return only entries matched to a Pharmacy Orderable Item
+9 ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is the Field Number of the data
+10 ; piece being returned.
+11 NEW DIERR,ZZERR,PSSP50,SCR,PSSMLCT,PSS
+12 IF $GET(LIST)']""
QUIT
+13 KILL ^TMP($JOB,LIST)
+14 IF +$GET(PSSIEN)'>0
IF ($GET(PSSFT)']"")
SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
QUIT
+15 SET SCR("S")=""
+16 IF +$GET(PSSFL)>0!($GET(PSSPK)]"")!($GET(PSSRTOI)=1)
NEW PSS5ND,PSSZ3,PSSZ4
DO SETSCRN^PSS50A
+17 IF +$GET(PSSIEN)>0
NEW PSSIEN2
SET PSSIEN2=$$FIND1^DIC(50,"","A","`"_PSSIEN,,SCR("S"),"")
Begin DoDot:1
+18 KILL ^TMP("DIERR",$JOB)
+19 IF +PSSIEN2'>0
SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
QUIT
+20 SET ^TMP($JOB,LIST,0)=1
+21 DO SETSUB7^PSS50AQM(+PSSIEN2)
DO SETSUB8^PSS50AQM(+PSSIEN2)
+22 KILL ^TMP("PSSP50",$JOB)
DO GETS^DIQ(50,+PSSIEN2,".01;901;902;903*;904*","IE","^TMP(""PSSP50"",$J)")
SET PSS(1)=0
+23 FOR
SET PSS(1)=$ORDER(^TMP("PSSP50",$JOB,50,PSS(1)))
if 'PSS(1)
QUIT
DO SDOSE^PSS50DOS
Begin DoDot:2
+24 SET (PSS(2),PSSMLCT)=0
FOR
SET PSS(2)=$ORDER(^TMP("PSSP50",$JOB,50.0903,PSS(2)))
if 'PSS(2)
QUIT
SET PSSMLCT=PSSMLCT+1
DO SDOSE2^PSS50DOS
+25 SET ^TMP($JOB,LIST,+PSS(1),"POS",0)=$SELECT($GET(PSSMLCT):PSSMLCT,1:"-1^NO DATA FOUND")
+26 SET (PSS(2),PSSMLCT)=0
FOR
SET PSS(2)=$ORDER(^TMP("PSSP50",$JOB,50.0904,PSS(2)))
if 'PSS(2)
QUIT
SET PSSMLCT=PSSMLCT+1
DO SDOSE3^PSS50DOS
+27 SET ^TMP($JOB,LIST,+PSS(1),"LOC",0)=$SELECT($GET(PSSMLCT):PSSMLCT,1:"-1^NO DATA FOUND")
End DoDot:2
End DoDot:1
KILL ^TMP("PSSP50",$JOB)
QUIT
+28 IF $GET(PSSIEN)'=""
SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
QUIT
+29 IF $GET(PSSFT)]""
Begin DoDot:1
+30 IF PSSFT["??"
DO LOOP^PSS50DOS
QUIT
+31 KILL ^TMP("DILIST",$JOB)
+32 DO FIND^DIC(50,,"@;.01","QP",PSSFT,,"B",SCR("S"),,"")
+33 IF +$GET(^TMP("DILIST",$JOB,0))=0
SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
QUIT
+34 IF +^TMP("DILIST",$JOB,0)>0
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:2
+35 SET PSSIEN=+^TMP("DILIST",$JOB,PSSXX,0)
+36 DO SETSUB7^PSS50AQM(PSSIEN)
DO SETSUB8^PSS50AQM(PSSIEN)
KILL ^TMP("PSSP50",$JOB)
DO GETS^DIQ(50,+PSSIEN,".01;901;902;903*;904*","IE","^TMP(""PSSP50"",$J)")
SET PSS(1)=0
+37 FOR
SET PSS(1)=$ORDER(^TMP("PSSP50",$JOB,50,PSS(1)))
if 'PSS(1)
QUIT
DO SDOSE^PSS50DOS
Begin DoDot:3
+38 SET (PSS(2),PSSMLCT)=0
FOR
SET PSS(2)=$ORDER(^TMP("PSSP50",$JOB,50.0903,PSS(2)))
if 'PSS(2)
QUIT
SET PSSMLCT=PSSMLCT+1
DO SDOSE2^PSS50DOS
+39 SET ^TMP($JOB,LIST,+PSS(1),"POS",0)=$SELECT($GET(PSSMLCT):PSSMLCT,1:"-1^NO DATA FOUND")
+40 SET (PSS(2),PSSMLCT)=0
FOR
SET PSS(2)=$ORDER(^TMP("PSSP50",$JOB,50.0904,PSS(2)))
if 'PSS(2)
QUIT
SET PSSMLCT=PSSMLCT+1
DO SDOSE3^PSS50DOS
+41 SET ^TMP($JOB,LIST,+PSS(1),"LOC",0)=$SELECT($GET(PSSMLCT):PSSMLCT,1:"-1^NO DATA FOUND")
End DoDot:3
End DoDot:2
End DoDot:1
+42 KILL ^TMP("DILIST",$JOB),^TMP("PSSP50",$JOB)
+43 QUIT
