PSS52P6B ;BIR/LDT - API FOR INFORMATION FROM FILE 52.6 CONT.; 5 Sep 03
;;1.0;PHARMACY DATA MANAGEMENT;**85**;9/30/97
;
ELYTES ;
S SCR("S")=""
I +$G(PSSFL)>0 N ND D SETSCRN^PSS52P6A
I +$G(PSSIEN)>0 N PSSIEN2 S PSSIEN2=$$FIND1^DIC(52.6,"","A","`"_PSSIEN,,SCR("S"),"") D
.I +PSSIEN2'>0 S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
.S ^TMP($J,LIST,0)=1
.D GETS^DIQ(52.6,+PSSIEN2,".01;8*","IE","^TMP(""PSS52P6"",$J)") S PSS(1)=0
.F S PSS(1)=$O(^TMP("PSS52P6",$J,52.6,PSS(1))) Q:'PSS(1) D
..S ^TMP($J,LIST,+PSSIEN2,.01)=^TMP("PSS52P6",$J,52.6,PSS(1),.01,"I")
..S ^TMP($J,LIST,"B",^TMP("PSS52P6",$J,52.6,PSS(1),.01,"I"),+PSSIEN2)=""
.N CNT S (PSS(1),CNT)=0 F S PSS(1)=$O(^TMP("PSS52P6",$J,52.62,PSS(1))) Q:'PSS(1) D SETLTS^PSS52P6A S CNT=CNT+1
.S ^TMP($J,LIST,+PSSIEN,"ELYTES",0)=$S(CNT>0:CNT,1:"-1^NO DATA FOUND")
I +$G(PSSIEN)'>0,$G(PSSFT)]"" D
.I PSSFT["??" D LOOP^PSS52P6A(3) Q
.D FIND^DIC(52.6,,"@;.01;2","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("PSS52P6",$J) D GETS^DIQ(52.6,+PSSIEN,"8*","IE","^TMP(""PSS52P6"",$J)") D
...S ^TMP($J,LIST,+PSSIEN,.01)=$P(^TMP("DILIST",$J,PSSXX,0),"^",2)
...S ^TMP($J,LIST,"B",$P(^TMP("DILIST",$J,PSSXX,0),"^",2),+PSSIEN)=""
..N CNT S (PSS(1),CNT)=0 F S PSS(1)=$O(^TMP("PSS52P6",$J,52.62,PSS(1))) Q:'PSS(1) D SETLTS^PSS52P6A S CNT=CNT+1
..S ^TMP($J,LIST,+PSSIEN,"ELYTES",0)=$S(CNT>0:CNT,1:"-1^NO DATA FOUND")
K ^TMP("DILIST",$J),^TMP("PSS52P6",$J)
Q
;
SYNONYM ;
S SCR("S")=""
I +$G(PSSFL)>0 N ND D SETSCRN^PSS52P6A
I +$G(PSSIEN)>0 N PSSIEN2 S PSSIEN2=$$FIND1^DIC(52.6,"","A","`"_PSSIEN,,SCR("S"),"") D
.I +PSSIEN2'>0 S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
.S ^TMP($J,LIST,0)=1
.D GETS^DIQ(52.6,+PSSIEN2,".01;9*","IE","^TMP(""PSS52P6"",$J)") S PSS(1)=0
.N CNT S (PSS(1),CNT)=0 F S PSS(1)=$O(^TMP("PSS52P6",$J,52.63,PSS(1))) Q:'PSS(1) D SETSYN^PSS52P6A S CNT=CNT+1
.S PSS(2)=0 F S PSS(2)=$O(^TMP("PSS52P6",$J,52.6,PSS(2))) Q:'PSS(2) D
..S ^TMP($J,LIST,+PSS(2),.01)=^TMP("PSS52P6",$J,52.6,PSS(2),.01,"I")
..S ^TMP($J,LIST,"B",^TMP("PSS52P6",$J,52.6,PSS(2),.01,"I"),+PSS(2))=""
.S ^TMP($J,LIST,+PSSIEN,"SYN",0)=$S(CNT>0:CNT,1:"-1^NO DATA FOUND")
I +$G(PSSIEN)'>0,$G(PSSFT)]"" D
.I PSSFT["??" D LOOP^PSS52P6A(4) Q
.D FIND^DIC(52.6,,"@;.01;2","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("PSS52P6",$J) D GETS^DIQ(52.6,+PSSIEN,"9*","IE","^TMP(""PSS52P6"",$J)") D
...S ^TMP($J,LIST,+PSSIEN,.01)=$P(^TMP("DILIST",$J,PSSXX,0),"^",2)
...S ^TMP($J,LIST,"B",$P(^TMP("DILIST",$J,PSSXX,0),"^",2),+PSSIEN)=""
..N CNT S (PSS(1),CNT)=0 F S PSS(1)=$O(^TMP("PSS52P6",$J,52.63,PSS(1))) Q:'PSS(1) D SETSYN^PSS52P6A S CNT=CNT+1
..S ^TMP($J,LIST,+PSSIEN,"SYN",0)=$S(CNT>0:CNT,1:"-1^NO DATA FOUND")
K ^TMP("DILIST",$J),^TMP("PSS52P6",$J)
Q
;
DRGINFO ;
S SCR("S")=""
I +$G(PSSFL)>1 N ND D SETSCRN^PSS52P6A
I +$G(PSSIEN)>0 N PSSIEN2 S PSSIEN2=$$FIND1^DIC(52.6,"","A","`"_PSSIEN,,SCR("S"),"") D
.I +PSSIEN2'>0 S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
.S ^TMP($J,LIST,0)=1
.D GETS^DIQ(52.6,+PSSIEN2,".01;10","E","^TMP(""PSS52P6"",$J)")
.S PSS(1)=0 F S PSS(1)=$O(^TMP("PSS52P6",$J,52.6,PSS(1))) Q:'PSS(1) D
..S ^TMP($J,LIST,+PSS(1),.01)=^TMP("PSS52P6",$J,52.6,PSS(1),.01,"E")
..S ^TMP($J,LIST,"B",^TMP("PSS52P6",$J,52.6,PSS(1),.01,"E"),+PSS(1))=""
..S PSS(3)=0 F S PSS(3)=$O(^TMP("PSS52P6",$J,52.6,PSS(1),10,PSS(3))) Q:'PSS(3) D SETDRI^PSS52P6A
..I '$D(^TMP($J,LIST,+PSS(1),"DRGINF")) S ^TMP($J,LIST,+PSS(1),"DRGINF",0)="-1^NO DATA FOUND"
I +$G(PSSIEN)'>0,$G(PSSFT)]"" D
.I PSSFT["??" D LOOP^PSS52P6A(5) Q
.D FIND^DIC(52.6,,"@;.01","QP",PSSFT,,"B^C^D",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("PSS52P6",$J) D GETS^DIQ(52.6,+PSSIEN,".01;10","E","^TMP(""PSS52P6"",$J)") S PSS(1)=0
..F S PSS(1)=$O(^TMP("PSS52P6",$J,52.6,PSS(1))) Q:'PSS(1) D
...S ^TMP($J,LIST,+PSS(1),.01)=^TMP("PSS52P6",$J,52.6,PSS(1),.01,"E")
...S ^TMP($J,LIST,"B",^TMP("PSS52P6",$J,52.6,PSS(1),.01,"E"),+PSS(1))=""
...S PSS(3)=0 F S PSS(3)=$O(^TMP("PSS52P6",$J,52.6,PSS(1),10,PSS(3))) Q:'PSS(3) D SETDRI^PSS52P6A
...I '$D(^TMP($J,LIST,+PSS(1),"DRGINF")) S ^TMP($J,LIST,+PSS(1),"DRGINF",0)="-1^NO DATA FOUND"
K ^TMP("DILIST",$J),^TMP("PSS52P6",$J)
Q
;
DRGIEN ;
S SCR("S")=""
I +$G(PSSFL)>0 N ND D SETSCRN^PSS52P6A
D FIND^DIC(52.6,,"@;.01","QPX",PSS50,,"AC",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 XX S XX=0 F S XX=$O(^TMP("DILIST",$J,XX)) Q:'XX D
.S ^TMP($J,LIST,+^TMP("DILIST",$J,XX,0),.01)=$P(^TMP("DILIST",$J,XX,0),"^",2)
.S ^TMP($J,LIST,"AC",$P(^TMP("DILIST",$J,XX,0),"^",2),+^TMP("DILIST",$J,XX,0))=""
K ^TMP("DILIST",$J)
Q
;
LOOKUP ;
S SCR("S")="" N PSSIEN,CNT,CNT2,CNT3,QFLG S CNT3=0
I +$G(PSSFL)>0 N ND D SETSCRN^PSS52P6A
I +$G(PSS50P7)>0 D FIND^DIC(52.6,,"@;.01","QPX",PSS50P7,,"AOI",SCR("S"),,"")
I +$G(^TMP("DILIST",$J,0))=0 S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
N PSSXX S PSSXX=0 F S PSSXX=$O(^TMP("DILIST",$J,PSSXX)) Q:'PSSXX D
.S PSSIEN=$P(^TMP("DILIST",$J,PSSXX,0),"^")
.K PSS52P6 D GETS^DIQ(52.6,+PSSIEN,"1","I","PSS52P6") S QFLG=0 D CHK:+$G(PSSFL)>0 Q:QFLG
.K ^TMP("PSS52P6",$J) D GETS^DIQ(52.6,+PSSIEN,".01;14;6*;9*","IE","^TMP(""PSS52P6"",$J)") S PSS(1)=0 D
..F S PSS(1)=$O(^TMP("PSS52P6",$J,52.6,PSS(1))) Q:'PSS(1) D SETZRO2^PSS52P6A S CNT3=CNT3+1
..S ^TMP($J,LIST,0)=$S(CNT3>0:CNT3,1:"-1^NO DATA FOUND")
..S (PSS(2),CNT)=0 F S PSS(2)=$O(^TMP("PSS52P6",$J,52.61,PSS(2))) Q:'PSS(2) D SETQCD2^PSS52P6A S CNT=CNT+1
..S ^TMP($J,LIST,+PSSIEN,"QCODE",0)=$S(CNT>0:CNT,1:"-1^NO DATA FOUND")
..S (PSS(3),CNT2)=0 F S PSS(3)=$O(^TMP("PSS52P6",$J,52.63,PSS(3))) Q:'PSS(3) D SETSYN2^PSS52P6A S CNT2=CNT2+1
..S ^TMP($J,LIST,+PSSIEN,"SYN",0)=$S(CNT2>0:CNT2,1:"-1^NO DATA FOUND")
K ^TMP("DILIST",$J),^TMP("PSS52P6",$J)
Q
;
POI ;
S SCR("S")=""
I +$G(PSSFL)>0 N ND D SETSCRN^PSS52P6A
D FIND^DIC(52.6,,"@;.01","QPX",PSSOI,,"AOI",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 XX S XX=0 F S XX=$O(^TMP("DILIST",$J,XX)) Q:'XX D
.S ^TMP($J,LIST,+^TMP("DILIST",$J,XX,0),.01)=$P(^TMP("DILIST",$J,XX,0),"^",2)
.S ^TMP($J,LIST,"AOI",$P(^TMP("DILIST",$J,XX,0),"^",2),+^TMP("DILIST",$J,XX,0))=""
K ^TMP("DILIST",$J)
Q
;
CHK ;
N PSS,PSS50,PSSINACT S PSS=0 F S PSS=$O(PSS52P6(52.6,PSS)) Q:'PSS D
.S PSS50=$S($G(PSS52P6(52.6,PSS,1,"I"))]"":$G(PSS52P6(52.6,PSS,1,"I")),1:"")
.I +$G(PSS50)'>0 S QFLG=1 Q
.D GETS^DIQ(50,+PSS50,"100","I","PSSINACT")
.S PSS(4)=0 F S PSS(4)=$O(PSSINACT(50,PSS(4))) Q:'PSS(4) D
..S PSSINACT(1)=$G(PSSINACT(50,PSS(4),1,"I")) I PSSINACT(1)'="",(PSSINACT(1)>+$G(PSSFL)) S QFLG=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSS52P6B 7471 printed Oct 16, 2024@18:30:55 Page 2
PSS52P6B ;BIR/LDT - API FOR INFORMATION FROM FILE 52.6 CONT.; 5 Sep 03
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**85**;9/30/97
+2 ;
ELYTES ;
+1 SET SCR("S")=""
+2 IF +$GET(PSSFL)>0
NEW ND
DO SETSCRN^PSS52P6A
+3 IF +$GET(PSSIEN)>0
NEW PSSIEN2
SET PSSIEN2=$$FIND1^DIC(52.6,"","A","`"_PSSIEN,,SCR("S"),"")
Begin DoDot:1
+4 IF +PSSIEN2'>0
SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
QUIT
+5 SET ^TMP($JOB,LIST,0)=1
+6 DO GETS^DIQ(52.6,+PSSIEN2,".01;8*","IE","^TMP(""PSS52P6"",$J)")
SET PSS(1)=0
+7 FOR
SET PSS(1)=$ORDER(^TMP("PSS52P6",$JOB,52.6,PSS(1)))
if 'PSS(1)
QUIT
Begin DoDot:2
+8 SET ^TMP($JOB,LIST,+PSSIEN2,.01)=^TMP("PSS52P6",$JOB,52.6,PSS(1),.01,"I")
+9 SET ^TMP($JOB,LIST,"B",^TMP("PSS52P6",$JOB,52.6,PSS(1),.01,"I"),+PSSIEN2)=""
End DoDot:2
+10 NEW CNT
SET (PSS(1),CNT)=0
FOR
SET PSS(1)=$ORDER(^TMP("PSS52P6",$JOB,52.62,PSS(1)))
if 'PSS(1)
QUIT
DO SETLTS^PSS52P6A
SET CNT=CNT+1
+11 SET ^TMP($JOB,LIST,+PSSIEN,"ELYTES",0)=$SELECT(CNT>0:CNT,1:"-1^NO DATA FOUND")
End DoDot:1
+12 IF +$GET(PSSIEN)'>0
IF $GET(PSSFT)]""
Begin DoDot:1
+13 IF PSSFT["??"
DO LOOP^PSS52P6A(3)
QUIT
+14 DO FIND^DIC(52.6,,"@;.01;2","QP",PSSFT,,"B",SCR("S"),,"")
+15 IF +$GET(^TMP("DILIST",$JOB,0))=0
SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
QUIT
+16 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
+17 SET PSSIEN=+^TMP("DILIST",$JOB,PSSXX,0)
KILL ^TMP("PSS52P6",$JOB)
DO GETS^DIQ(52.6,+PSSIEN,"8*","IE","^TMP(""PSS52P6"",$J)")
Begin DoDot:3
+18 SET ^TMP($JOB,LIST,+PSSIEN,.01)=$PIECE(^TMP("DILIST",$JOB,PSSXX,0),"^",2)
+19 SET ^TMP($JOB,LIST,"B",$PIECE(^TMP("DILIST",$JOB,PSSXX,0),"^",2),+PSSIEN)=""
End DoDot:3
+20 NEW CNT
SET (PSS(1),CNT)=0
FOR
SET PSS(1)=$ORDER(^TMP("PSS52P6",$JOB,52.62,PSS(1)))
if 'PSS(1)
QUIT
DO SETLTS^PSS52P6A
SET CNT=CNT+1
+21 SET ^TMP($JOB,LIST,+PSSIEN,"ELYTES",0)=$SELECT(CNT>0:CNT,1:"-1^NO DATA FOUND")
End DoDot:2
End DoDot:1
+22 KILL ^TMP("DILIST",$JOB),^TMP("PSS52P6",$JOB)
+23 QUIT
+24 ;
SYNONYM ;
+1 SET SCR("S")=""
+2 IF +$GET(PSSFL)>0
NEW ND
DO SETSCRN^PSS52P6A
+3 IF +$GET(PSSIEN)>0
NEW PSSIEN2
SET PSSIEN2=$$FIND1^DIC(52.6,"","A","`"_PSSIEN,,SCR("S"),"")
Begin DoDot:1
+4 IF +PSSIEN2'>0
SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
QUIT
+5 SET ^TMP($JOB,LIST,0)=1
+6 DO GETS^DIQ(52.6,+PSSIEN2,".01;9*","IE","^TMP(""PSS52P6"",$J)")
SET PSS(1)=0
+7 NEW CNT
SET (PSS(1),CNT)=0
FOR
SET PSS(1)=$ORDER(^TMP("PSS52P6",$JOB,52.63,PSS(1)))
if 'PSS(1)
QUIT
DO SETSYN^PSS52P6A
SET CNT=CNT+1
+8 SET PSS(2)=0
FOR
SET PSS(2)=$ORDER(^TMP("PSS52P6",$JOB,52.6,PSS(2)))
if 'PSS(2)
QUIT
Begin DoDot:2
+9 SET ^TMP($JOB,LIST,+PSS(2),.01)=^TMP("PSS52P6",$JOB,52.6,PSS(2),.01,"I")
+10 SET ^TMP($JOB,LIST,"B",^TMP("PSS52P6",$JOB,52.6,PSS(2),.01,"I"),+PSS(2))=""
End DoDot:2
+11 SET ^TMP($JOB,LIST,+PSSIEN,"SYN",0)=$SELECT(CNT>0:CNT,1:"-1^NO DATA FOUND")
End DoDot:1
+12 IF +$GET(PSSIEN)'>0
IF $GET(PSSFT)]""
Begin DoDot:1
+13 IF PSSFT["??"
DO LOOP^PSS52P6A(4)
QUIT
+14 DO FIND^DIC(52.6,,"@;.01;2","QP",PSSFT,,"B",SCR("S"),,"")
+15 IF +$GET(^TMP("DILIST",$JOB,0))=0
SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
QUIT
+16 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
+17 SET PSSIEN=+^TMP("DILIST",$JOB,PSSXX,0)
KILL ^TMP("PSS52P6",$JOB)
DO GETS^DIQ(52.6,+PSSIEN,"9*","IE","^TMP(""PSS52P6"",$J)")
Begin DoDot:3
+18 SET ^TMP($JOB,LIST,+PSSIEN,.01)=$PIECE(^TMP("DILIST",$JOB,PSSXX,0),"^",2)
+19 SET ^TMP($JOB,LIST,"B",$PIECE(^TMP("DILIST",$JOB,PSSXX,0),"^",2),+PSSIEN)=""
End DoDot:3
+20 NEW CNT
SET (PSS(1),CNT)=0
FOR
SET PSS(1)=$ORDER(^TMP("PSS52P6",$JOB,52.63,PSS(1)))
if 'PSS(1)
QUIT
DO SETSYN^PSS52P6A
SET CNT=CNT+1
+21 SET ^TMP($JOB,LIST,+PSSIEN,"SYN",0)=$SELECT(CNT>0:CNT,1:"-1^NO DATA FOUND")
End DoDot:2
End DoDot:1
+22 KILL ^TMP("DILIST",$JOB),^TMP("PSS52P6",$JOB)
+23 QUIT
+24 ;
DRGINFO ;
+1 SET SCR("S")=""
+2 IF +$GET(PSSFL)>1
NEW ND
DO SETSCRN^PSS52P6A
+3 IF +$GET(PSSIEN)>0
NEW PSSIEN2
SET PSSIEN2=$$FIND1^DIC(52.6,"","A","`"_PSSIEN,,SCR("S"),"")
Begin DoDot:1
+4 IF +PSSIEN2'>0
SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
QUIT
+5 SET ^TMP($JOB,LIST,0)=1
+6 DO GETS^DIQ(52.6,+PSSIEN2,".01;10","E","^TMP(""PSS52P6"",$J)")
+7 SET PSS(1)=0
FOR
SET PSS(1)=$ORDER(^TMP("PSS52P6",$JOB,52.6,PSS(1)))
if 'PSS(1)
QUIT
Begin DoDot:2
+8 SET ^TMP($JOB,LIST,+PSS(1),.01)=^TMP("PSS52P6",$JOB,52.6,PSS(1),.01,"E")
+9 SET ^TMP($JOB,LIST,"B",^TMP("PSS52P6",$JOB,52.6,PSS(1),.01,"E"),+PSS(1))=""
+10 SET PSS(3)=0
FOR
SET PSS(3)=$ORDER(^TMP("PSS52P6",$JOB,52.6,PSS(1),10,PSS(3)))
if 'PSS(3)
QUIT
DO SETDRI^PSS52P6A
+11 IF '$DATA(^TMP($JOB,LIST,+PSS(1),"DRGINF"))
SET ^TMP($JOB,LIST,+PSS(1),"DRGINF",0)="-1^NO DATA FOUND"
End DoDot:2
End DoDot:1
+12 IF +$GET(PSSIEN)'>0
IF $GET(PSSFT)]""
Begin DoDot:1
+13 IF PSSFT["??"
DO LOOP^PSS52P6A(5)
QUIT
+14 DO FIND^DIC(52.6,,"@;.01","QP",PSSFT,,"B^C^D",SCR("S"),,"")
+15 IF +$GET(^TMP("DILIST",$JOB,0))=0
SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
QUIT
+16 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
+17 SET PSSIEN=+^TMP("DILIST",$JOB,PSSXX,0)
KILL ^TMP("PSS52P6",$JOB)
DO GETS^DIQ(52.6,+PSSIEN,".01;10","E","^TMP(""PSS52P6"",$J)")
SET PSS(1)=0
+18 FOR
SET PSS(1)=$ORDER(^TMP("PSS52P6",$JOB,52.6,PSS(1)))
if 'PSS(1)
QUIT
Begin DoDot:3
+19 SET ^TMP($JOB,LIST,+PSS(1),.01)=^TMP("PSS52P6",$JOB,52.6,PSS(1),.01,"E")
+20 SET ^TMP($JOB,LIST,"B",^TMP("PSS52P6",$JOB,52.6,PSS(1),.01,"E"),+PSS(1))=""
+21 SET PSS(3)=0
FOR
SET PSS(3)=$ORDER(^TMP("PSS52P6",$JOB,52.6,PSS(1),10,PSS(3)))
if 'PSS(3)
QUIT
DO SETDRI^PSS52P6A
+22 IF '$DATA(^TMP($JOB,LIST,+PSS(1),"DRGINF"))
SET ^TMP($JOB,LIST,+PSS(1),"DRGINF",0)="-1^NO DATA FOUND"
End DoDot:3
End DoDot:2
End DoDot:1
+23 KILL ^TMP("DILIST",$JOB),^TMP("PSS52P6",$JOB)
+24 QUIT
+25 ;
DRGIEN ;
+1 SET SCR("S")=""
+2 IF +$GET(PSSFL)>0
NEW ND
DO SETSCRN^PSS52P6A
+3 DO FIND^DIC(52.6,,"@;.01","QPX",PSS50,,"AC",SCR("S"),,"")
+4 IF +$GET(^TMP("DILIST",$JOB,0))=0
SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
QUIT
+5 IF +^TMP("DILIST",$JOB,0)>0
SET ^TMP($JOB,LIST,0)=+^TMP("DILIST",$JOB,0)
NEW XX
SET XX=0
FOR
SET XX=$ORDER(^TMP("DILIST",$JOB,XX))
if 'XX
QUIT
Begin DoDot:1
+6 SET ^TMP($JOB,LIST,+^TMP("DILIST",$JOB,XX,0),.01)=$PIECE(^TMP("DILIST",$JOB,XX,0),"^",2)
+7 SET ^TMP($JOB,LIST,"AC",$PIECE(^TMP("DILIST",$JOB,XX,0),"^",2),+^TMP("DILIST",$JOB,XX,0))=""
End DoDot:1
+8 KILL ^TMP("DILIST",$JOB)
+9 QUIT
+10 ;
LOOKUP ;
+1 SET SCR("S")=""
NEW PSSIEN,CNT,CNT2,CNT3,QFLG
SET CNT3=0
+2 IF +$GET(PSSFL)>0
NEW ND
DO SETSCRN^PSS52P6A
+3 IF +$GET(PSS50P7)>0
DO FIND^DIC(52.6,,"@;.01","QPX",PSS50P7,,"AOI",SCR("S"),,"")
+4 IF +$GET(^TMP("DILIST",$JOB,0))=0
SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
QUIT
+5 NEW PSSXX
SET PSSXX=0
FOR
SET PSSXX=$ORDER(^TMP("DILIST",$JOB,PSSXX))
if 'PSSXX
QUIT
Begin DoDot:1
+6 SET PSSIEN=$PIECE(^TMP("DILIST",$JOB,PSSXX,0),"^")
+7 KILL PSS52P6
DO GETS^DIQ(52.6,+PSSIEN,"1","I","PSS52P6")
SET QFLG=0
if +$GET(PSSFL)>0
DO CHK
if QFLG
QUIT
+8 KILL ^TMP("PSS52P6",$JOB)
DO GETS^DIQ(52.6,+PSSIEN,".01;14;6*;9*","IE","^TMP(""PSS52P6"",$J)")
SET PSS(1)=0
Begin DoDot:2
+9 FOR
SET PSS(1)=$ORDER(^TMP("PSS52P6",$JOB,52.6,PSS(1)))
if 'PSS(1)
QUIT
DO SETZRO2^PSS52P6A
SET CNT3=CNT3+1
+10 SET ^TMP($JOB,LIST,0)=$SELECT(CNT3>0:CNT3,1:"-1^NO DATA FOUND")
+11 SET (PSS(2),CNT)=0
FOR
SET PSS(2)=$ORDER(^TMP("PSS52P6",$JOB,52.61,PSS(2)))
if 'PSS(2)
QUIT
DO SETQCD2^PSS52P6A
SET CNT=CNT+1
+12 SET ^TMP($JOB,LIST,+PSSIEN,"QCODE",0)=$SELECT(CNT>0:CNT,1:"-1^NO DATA FOUND")
+13 SET (PSS(3),CNT2)=0
FOR
SET PSS(3)=$ORDER(^TMP("PSS52P6",$JOB,52.63,PSS(3)))
if 'PSS(3)
QUIT
DO SETSYN2^PSS52P6A
SET CNT2=CNT2+1
+14 SET ^TMP($JOB,LIST,+PSSIEN,"SYN",0)=$SELECT(CNT2>0:CNT2,1:"-1^NO DATA FOUND")
End DoDot:2
End DoDot:1
+15 KILL ^TMP("DILIST",$JOB),^TMP("PSS52P6",$JOB)
+16 QUIT
+17 ;
POI ;
+1 SET SCR("S")=""
+2 IF +$GET(PSSFL)>0
NEW ND
DO SETSCRN^PSS52P6A
+3 DO FIND^DIC(52.6,,"@;.01","QPX",PSSOI,,"AOI",SCR("S"),,"")
+4 IF +$GET(^TMP("DILIST",$JOB,0))=0
SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
QUIT
+5 IF +^TMP("DILIST",$JOB,0)>0
SET ^TMP($JOB,LIST,0)=+^TMP("DILIST",$JOB,0)
NEW XX
SET XX=0
FOR
SET XX=$ORDER(^TMP("DILIST",$JOB,XX))
if 'XX
QUIT
Begin DoDot:1
+6 SET ^TMP($JOB,LIST,+^TMP("DILIST",$JOB,XX,0),.01)=$PIECE(^TMP("DILIST",$JOB,XX,0),"^",2)
+7 SET ^TMP($JOB,LIST,"AOI",$PIECE(^TMP("DILIST",$JOB,XX,0),"^",2),+^TMP("DILIST",$JOB,XX,0))=""
End DoDot:1
+8 KILL ^TMP("DILIST",$JOB)
+9 QUIT
+10 ;
CHK ;
+1 NEW PSS,PSS50,PSSINACT
SET PSS=0
FOR
SET PSS=$ORDER(PSS52P6(52.6,PSS))
if 'PSS
QUIT
Begin DoDot:1
+2 SET PSS50=$SELECT($GET(PSS52P6(52.6,PSS,1,"I"))]"":$GET(PSS52P6(52.6,PSS,1,"I")),1:"")
+3 IF +$GET(PSS50)'>0
SET QFLG=1
QUIT
+4 DO GETS^DIQ(50,+PSS50,"100","I","PSSINACT")
+5 SET PSS(4)=0
FOR
SET PSS(4)=$ORDER(PSSINACT(50,PSS(4)))
if 'PSS(4)
QUIT
Begin DoDot:2
+6 SET PSSINACT(1)=$GET(PSSINACT(50,PSS(4),1,"I"))
IF PSSINACT(1)'=""
IF (PSSINACT(1)>+$GET(PSSFL))
SET QFLG=1
End DoDot:2
End DoDot:1
+7 QUIT
