- 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 Feb 18, 2025@23:56:15 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
