PSS50B2 ;BIR/LDT - API FOR INFORMATION FROM FILE 50; 5 Sep 03
;;1.0;PHARMACY DATA MANAGEMENT;**85**;9/30/97
;
CLOZ ;
;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
I $G(PSSIEN)]"",+$G(PSSIEN)'>0 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 SETSUB6^PSS50AQM(+PSSIEN2)
.K ^TMP("PSSP50",$J) D GETS^DIQ(50,+PSSIEN2,".01;17.7*","IE","^TMP(""PSSP50"",$J)") S PSS(1)=0
.F S PSS(1)=$O(^TMP("PSSP50",$J,50,PSS(1))) Q:'PSS(1) D SCLOZ D
..S (PSS(2),PSSMLCT)=0 F S PSS(2)=$O(^TMP("PSSP50",$J,50.02,PSS(2))) Q:'PSS(2) S PSSMLCT=PSSMLCT+1 D SCLOZM
..S ^TMP($J,LIST,+PSS(1),"CLOZ",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 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 SETSUB6^PSS50AQM(PSSIEN) K ^TMP("PSSP50",$J) D GETS^DIQ(50,+PSSIEN,".01;17.7*","IE","^TMP(""PSSP50"",$J)") S PSS(1)=0
..F S PSS(1)=$O(^TMP("PSSP50",$J,50,PSS(1))) Q:'PSS(1) D SCLOZ D
...S (PSS(2),PSSMLCT)=0 F S PSS(2)=$O(^TMP("PSSP50",$J,50.02,PSS(2))) Q:'PSS(2) S PSSMLCT=PSSMLCT+1 D SCLOZM
...S ^TMP($J,LIST,+PSS(1),"CLOZ",0)=$S($G(PSSMLCT):PSSMLCT,1:"-1^NO DATA FOUND")
K ^TMP("DILIST",$J),^TMP("PSSP50",$J)
Q
;
FRMALT ;
;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.
;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,PSS50,SCR,PSSFRCT,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
I $G(PSSIEN)]"",+$G(PSSIEN)'>0 S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
S SCR("S")=""
I +$G(PSSFL)>0!($G(PSSPK)]"") 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("PSS50",$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;25;100;101;65*","IE","^TMP(""PSS50"",$J)") S PSS(1)=0
.F S PSS(1)=$O(^TMP("PSS50",$J,50,PSS(1))) Q:'PSS(1) D SFRM D
..S (PSS(2),PSSFRCT)=0 F S PSS(2)=$O(^TMP("PSS50",$J,50.065,PSS(2))) Q:'PSS(2) S PSSFRCT=PSSFRCT+1 D SFRMA
..S ^TMP($J,LIST,+PSS(1),"FRM",0)=$S($G(PSSFRCT):PSSFRCT,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 LOOP2 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("PSS50",$J) D GETS^DIQ(50,+PSSIEN,".01;25;100;101;65*","IE","^TMP(""PSS50"",$J)") S PSS(1)=0
..F S PSS(1)=$O(^TMP("PSS50",$J,50,PSS(1))) Q:'PSS(1) D SFRM D
...S (PSS(2),PSSFRCT)=0 F S PSS(2)=$O(^TMP("PSS50",$J,50.065,PSS(2))) Q:'PSS(2) S PSSFRCT=PSSFRCT+1 D SFRMA
...S ^TMP($J,LIST,+PSS(1),"FRM",0)=$S($G(PSSFRCT):PSSFRCT,1:"-1^NO DATA FOUND")
K ^TMP("DILIST",$J),^TMP("PSS50",$J)
Q
;
SCLOZ ;
S ^TMP($J,LIST,+PSS(1),.01)=$G(^TMP("PSSP50",$J,50,PSS(1),.01,"I"))
S ^TMP($J,LIST,"B",$G(^TMP("PSSP50",$J,50,PSS(1),.01,"I")),+PSS(1))=""
Q
SCLOZM ;
S ^TMP($J,LIST,+PSS(1),"CLOZ",+PSS(2),.01)=$S($G(^TMP("PSSP50",$J,50.02,PSS(2),.01,"I"))="":"",1:$G(^TMP("PSSP50",$J,50.02,PSS(2),.01,"I"))_"^"_$G(^TMP("PSSP50",$J,50.02,PSS(2),.01,"E")))
S ^TMP($J,LIST,+PSS(1),"CLOZ",+PSS(2),1)=$G(^TMP("PSSP50",$J,50.02,PSS(2),1,"I"))
S ^TMP($J,LIST,+PSS(1),"CLOZ",+PSS(2),2)=$S($G(^TMP("PSSP50",$J,50.02,PSS(2),2,"I"))="":"",1:$G(^TMP("PSSP50",$J,50.02,PSS(2),2,"I"))_"^"_$G(^TMP("PSSP50",$J,50.02,PSS(2),2,"E")))
S ^TMP($J,LIST,+PSS(1),"CLOZ",+PSS(2),3)=$S($G(^TMP("PSSP50",$J,50.02,PSS(2),3,"I"))="":"",1:$G(^TMP("PSSP50",$J,50.02,PSS(2),3,"I"))_"^"_$G(^TMP("PSSP50",$J,50.02,PSS(2),3,"E")))
Q
SFRM ;
S ^TMP($J,LIST,+PSS(1),.01)=$G(^TMP("PSS50",$J,50,PSS(1),.01,"I"))
S ^TMP($J,LIST,"B",$G(^TMP("PSS50",$J,50,PSS(1),.01,"I")),+PSS(1))=""
S ^TMP($J,LIST,+PSS(1),25)=$G(^TMP("PSS50",$J,50,PSS(1),25,"I"))
S ^TMP($J,LIST,+PSS(1),100)=$S($G(^TMP("PSS50",$J,50,PSS(1),100,"I"))="":"",1:$G(^TMP("PSS50",$J,50,PSS(1),100,"I"))_"^"_$G(^TMP("PSS50",$J,50,PSS(1),100,"E")))
S ^TMP($J,LIST,+PSS(1),101)=$G(^TMP("PSS50",$J,50,PSS(1),101,"I"))
Q
SFRMA ;
S ^TMP($J,LIST,+PSS(1),"FRM",+PSS(2),.01)=$S($G(^TMP("PSS50",$J,50.065,PSS(2),.01,"I"))="":"",1:$G(^TMP("PSS50",$J,50.065,PSS(2),.01,"I"))_"^"_$G(^TMP("PSS50",$J,50.065,PSS(2),.01,"E")))
Q
LOOP ;
N PSSENCT
S PSSENCT=0
S PSS(1)=0 F S PSS(1)=$O(^PSDRUG(PSS(1))) Q:'PSS(1) D
.I $P($G(^PSDRUG(PSS(1),0)),"^")="" Q
.I $G(PSSFL),$P($G(^PSDRUG(PSS(1),"I")),"^"),$P($G(^("I")),"^")'>PSSFL Q
.I $G(PSSRTOI)=1,'$P($G(^PSDRUG(PSS(1),2)),"^") Q
.;Naked reference below refers to ^PSDRUG(PSS(1),2)
.I $G(PSSPK)]"" N PSSZ5,PSSZ6 S PSSZ5=0 F PSSZ6=1:1:$L(PSSPK) Q:PSSZ5 I $P($G(^(2)),"^",3)[$E(PSSPK,PSSZ6) S PSSZ5=1
.I $G(PSSPK)]"",'PSSZ5 Q
.D SETSUB6^PSS50AQM(PSS(1))
.D SCLOZ1
.S PSSENCT=PSSENCT+1
S ^TMP($J,LIST,0)=$S($G(PSSENCT):$G(PSSENCT),1:"-1^NO DATA FOUND")
Q
SCLOZ1 ;
N PSSZNODE
S PSSZNODE=$G(^PSDRUG(PSS(1),0))
S ^TMP($J,LIST,+PSS(1),.01)=$P(PSSZNODE,"^")
S ^TMP($J,LIST,"B",$P(PSSZNODE,"^"),PSS(1))=""
;Set CLOZ2 multiple information
N PSSCZPC S PSSCZPC=0
I $O(^PSDRUG(PSS(1),"CLOZ2",0)) N PSSCZP,PSSCZP1 D
.F PSSCZP=0:0 S PSSCZP=$O(^PSDRUG(PSS(1),"CLOZ2",PSSCZP)) Q:'PSSCZP D
..S PSSCZP1=$G(^PSDRUG(PSS(1),"CLOZ2",PSSCZP,0)) I $P(PSSCZP1,"^")'="" S PSSCZPC=PSSCZPC+1 D
...N PSSCARZ,DA,DR,DIC,DIQ K PSSCARZ S DIC=50,DR="17.7",DA=PSS(1),DR(50.02)=".01;1;2;3",DA(50.02)=PSSCZP,DIQ="PSSCARZ",DIQ(0)="IE" D EN^DIQ1
...S ^TMP($J,LIST,+PSS(1),"CLOZ",PSSCZP,.01)=$S($G(PSSCARZ(50.02,PSSCZP,.01,"I"))="":"",1:$G(PSSCARZ(50.02,PSSCZP,.01,"I"))_"^"_$G(PSSCARZ(50.02,PSSCZP,.01,"E")))
...S ^TMP($J,LIST,+PSS(1),"CLOZ",PSSCZP,1)=$G(PSSCARZ(50.02,PSSCZP,1,"I"))
...S ^TMP($J,LIST,+PSS(1),"CLOZ",PSSCZP,2)=$S($G(PSSCARZ(50.02,PSSCZP,2,"I"))="":"",1:$G(PSSCARZ(50.02,PSSCZP,2,"I"))_"^"_$G(PSSCARZ(50.02,PSSCZP,2,"E")))
...S ^TMP($J,LIST,+PSS(1),"CLOZ",PSSCZP,3)=$S($G(PSSCARZ(50.02,PSSCZP,3,"I"))="":"",1:$G(PSSCARZ(50.02,PSSCZP,3,"I"))_"^"_$G(PSSCARZ(50.02,PSSCZP,3,"E")))
S ^TMP($J,LIST,+PSS(1),"CLOZ",0)=$S(PSSCZPC:PSSCZPC,1:"-1^NO DATA FOUND")
Q
LOOP2 ;
N PSSENCT,PSSIEN
S PSSENCT=0
S PSSIEN=0 F S PSSIEN=$O(^PSDRUG(PSSIEN)) Q:'PSSIEN D
.I $P($G(^PSDRUG(PSSIEN,0)),"^")="" Q
.I $G(PSSFL),$P($G(^PSDRUG(PSSIEN,"I")),"^"),$P($G(^("I")),"^")'>PSSFL Q
.;Naked reference below refers to ^PSDRUG(PSSIEN,2)
.I $G(PSSPK)]"" N PSSZ5,PSSZ6 S PSSZ5=0 F PSSZ6=1:1:$L(PSSPK) Q:PSSZ5 I $P($G(^(2)),"^",3)[$E(PSSPK,PSSZ6) S PSSZ5=1
.I $G(PSSPK)]"",'PSSZ5 Q
.K ^TMP("PSS50",$J) D GETS^DIQ(50,+PSSIEN,".01;25;100;101;65*","IE","^TMP(""PSS50"",$J)") S PSS(1)=0
.F S PSS(1)=$O(^TMP("PSS50",$J,50,PSS(1))) Q:'PSS(1) D SFRM D
..S (PSS(2),PSSFRCT)=0 F S PSS(2)=$O(^TMP("PSS50",$J,50.065,PSS(2))) Q:'PSS(2) S PSSFRCT=PSSFRCT+1 D SFRMA
..S ^TMP($J,LIST,+PSS(1),"FRM",0)=$S($G(PSSFRCT):PSSFRCT,1:"-1^NO DATA FOUND")
.S PSSENCT=PSSENCT+1
S ^TMP($J,LIST,0)=$S($G(PSSENCT):$G(PSSENCT),1:"-1^NO DATA FOUND")
K ^TMP("PSS50",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSS50B2 9283 printed Apr 09, 2024@21:32:39 Page 2
PSS50B2 ;BIR/LDT - API FOR INFORMATION FROM FILE 50; 5 Sep 03
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**85**;9/30/97
+2 ;
CLOZ ;
+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 IF $GET(PSSIEN)]""
IF +$GET(PSSIEN)'>0
SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
QUIT
+16 SET SCR("S")=""
+17 IF +$GET(PSSFL)>0!($GET(PSSPK)]"")!($GET(PSSRTOI)=1)
NEW PSS5ND,PSSZ3,PSSZ4
DO SETSCRN^PSS50A
+18 IF +$GET(PSSIEN)>0
NEW PSSIEN2
SET PSSIEN2=$$FIND1^DIC(50,"","A","`"_PSSIEN,,SCR("S"),"")
Begin DoDot:1
+19 KILL ^TMP("DIERR",$JOB)
+20 IF +PSSIEN2'>0
SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
QUIT
+21 SET ^TMP($JOB,LIST,0)=1
+22 DO SETSUB6^PSS50AQM(+PSSIEN2)
+23 KILL ^TMP("PSSP50",$JOB)
DO GETS^DIQ(50,+PSSIEN2,".01;17.7*","IE","^TMP(""PSSP50"",$J)")
SET PSS(1)=0
+24 FOR
SET PSS(1)=$ORDER(^TMP("PSSP50",$JOB,50,PSS(1)))
if 'PSS(1)
QUIT
DO SCLOZ
Begin DoDot:2
+25 SET (PSS(2),PSSMLCT)=0
FOR
SET PSS(2)=$ORDER(^TMP("PSSP50",$JOB,50.02,PSS(2)))
if 'PSS(2)
QUIT
SET PSSMLCT=PSSMLCT+1
DO SCLOZM
+26 SET ^TMP($JOB,LIST,+PSS(1),"CLOZ",0)=$SELECT($GET(PSSMLCT):PSSMLCT,1:"-1^NO DATA FOUND")
End DoDot:2
End DoDot:1
KILL ^TMP("PSSP50",$JOB)
QUIT
+27 IF $GET(PSSIEN)'=""
SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
QUIT
+28 IF $GET(PSSFT)]""
Begin DoDot:1
+29 IF PSSFT["??"
DO LOOP
QUIT
+30 KILL ^TMP("DILIST",$JOB)
+31 DO FIND^DIC(50,,"@;.01","QP",PSSFT,,"B",SCR("S"),,"")
+32 IF +$GET(^TMP("DILIST",$JOB,0))=0
SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
QUIT
+33 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
+34 SET PSSIEN=+^TMP("DILIST",$JOB,PSSXX,0)
+35 DO SETSUB6^PSS50AQM(PSSIEN)
KILL ^TMP("PSSP50",$JOB)
DO GETS^DIQ(50,+PSSIEN,".01;17.7*","IE","^TMP(""PSSP50"",$J)")
SET PSS(1)=0
+36 FOR
SET PSS(1)=$ORDER(^TMP("PSSP50",$JOB,50,PSS(1)))
if 'PSS(1)
QUIT
DO SCLOZ
Begin DoDot:3
+37 SET (PSS(2),PSSMLCT)=0
FOR
SET PSS(2)=$ORDER(^TMP("PSSP50",$JOB,50.02,PSS(2)))
if 'PSS(2)
QUIT
SET PSSMLCT=PSSMLCT+1
DO SCLOZM
+38 SET ^TMP($JOB,LIST,+PSS(1),"CLOZ",0)=$SELECT($GET(PSSMLCT):PSSMLCT,1:"-1^NO DATA FOUND")
End DoDot:3
End DoDot:2
End DoDot:1
+39 KILL ^TMP("DILIST",$JOB),^TMP("PSSP50",$JOB)
+40 QUIT
+41 ;
FRMALT ;
+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 ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is the Field Number of the data
+9 ; piece being returned.
+10 NEW DIERR,ZZERR,PSS50,SCR,PSSFRCT,PSS
+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 SET SCR("S")=""
+16 IF +$GET(PSSFL)>0!($GET(PSSPK)]"")
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;25;100;101;65*","IE","^TMP(""PSS50"",$J)")
SET PSS(1)=0
+22 FOR
SET PSS(1)=$ORDER(^TMP("PSS50",$JOB,50,PSS(1)))
if 'PSS(1)
QUIT
DO SFRM
Begin DoDot:2
+23 SET (PSS(2),PSSFRCT)=0
FOR
SET PSS(2)=$ORDER(^TMP("PSS50",$JOB,50.065,PSS(2)))
if 'PSS(2)
QUIT
SET PSSFRCT=PSSFRCT+1
DO SFRMA
+24 SET ^TMP($JOB,LIST,+PSS(1),"FRM",0)=$SELECT($GET(PSSFRCT):PSSFRCT,1:"-1^NO DATA FOUND")
End DoDot:2
End DoDot:1
KILL ^TMP("PSS50",$JOB)
QUIT
+25 IF $GET(PSSIEN)'=""
SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
QUIT
+26 IF $GET(PSSFT)]""
Begin DoDot:1
+27 IF PSSFT["??"
DO LOOP2
QUIT
+28 KILL ^TMP("DILIST",$JOB)
+29 DO FIND^DIC(50,,"@;.01","QP",PSSFT,,"B",SCR("S"),,"")
+30 IF +$GET(^TMP("DILIST",$JOB,0))=0
SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
QUIT
+31 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
+32 SET PSSIEN=+^TMP("DILIST",$JOB,PSSXX,0)
+33 KILL ^TMP("PSS50",$JOB)
DO GETS^DIQ(50,+PSSIEN,".01;25;100;101;65*","IE","^TMP(""PSS50"",$J)")
SET PSS(1)=0
+34 FOR
SET PSS(1)=$ORDER(^TMP("PSS50",$JOB,50,PSS(1)))
if 'PSS(1)
QUIT
DO SFRM
Begin DoDot:3
+35 SET (PSS(2),PSSFRCT)=0
FOR
SET PSS(2)=$ORDER(^TMP("PSS50",$JOB,50.065,PSS(2)))
if 'PSS(2)
QUIT
SET PSSFRCT=PSSFRCT+1
DO SFRMA
+36 SET ^TMP($JOB,LIST,+PSS(1),"FRM",0)=$SELECT($GET(PSSFRCT):PSSFRCT,1:"-1^NO DATA FOUND")
End DoDot:3
End DoDot:2
End DoDot:1
+37 KILL ^TMP("DILIST",$JOB),^TMP("PSS50",$JOB)
+38 QUIT
+39 ;
SCLOZ ;
+1 SET ^TMP($JOB,LIST,+PSS(1),.01)=$GET(^TMP("PSSP50",$JOB,50,PSS(1),.01,"I"))
+2 SET ^TMP($JOB,LIST,"B",$GET(^TMP("PSSP50",$JOB,50,PSS(1),.01,"I")),+PSS(1))=""
+3 QUIT
SCLOZM ;
+1 SET ^TMP($JOB,LIST,+PSS(1),"CLOZ",+PSS(2),.01)=$SELECT($GET(^TMP("PSSP50",$JOB,50.02,PSS(2),.01,"I"))="":"",1:$GET(^TMP("PSSP50",$JOB,50.02,PSS(2),.01,"I"))_"^"_$GET(^TMP("PSSP50",$JOB,50.02,PSS(2),.01,"E")))
+2 SET ^TMP($JOB,LIST,+PSS(1),"CLOZ",+PSS(2),1)=$GET(^TMP("PSSP50",$JOB,50.02,PSS(2),1,"I"))
+3 SET ^TMP($JOB,LIST,+PSS(1),"CLOZ",+PSS(2),2)=$SELECT($GET(^TMP("PSSP50",$JOB,50.02,PSS(2),2,"I"))="":"",1:$GET(^TMP("PSSP50",$JOB,50.02,PSS(2),2,"I"))_"^"_$GET(^TMP("PSSP50",$JOB,50.02,PSS(2),2,"E")))
+4 SET ^TMP($JOB,LIST,+PSS(1),"CLOZ",+PSS(2),3)=$SELECT($GET(^TMP("PSSP50",$JOB,50.02,PSS(2),3,"I"))="":"",1:$GET(^TMP("PSSP50",$JOB,50.02,PSS(2),3,"I"))_"^"_$GET(^TMP("PSSP50",$JOB,50.02,PSS(2),3,"E")))
+5 QUIT
SFRM ;
+1 SET ^TMP($JOB,LIST,+PSS(1),.01)=$GET(^TMP("PSS50",$JOB,50,PSS(1),.01,"I"))
+2 SET ^TMP($JOB,LIST,"B",$GET(^TMP("PSS50",$JOB,50,PSS(1),.01,"I")),+PSS(1))=""
+3 SET ^TMP($JOB,LIST,+PSS(1),25)=$GET(^TMP("PSS50",$JOB,50,PSS(1),25,"I"))
+4 SET ^TMP($JOB,LIST,+PSS(1),100)=$SELECT($GET(^TMP("PSS50",$JOB,50,PSS(1),100,"I"))="":"",1:$GET(^TMP("PSS50",$JOB,50,PSS(1),100,"I"))_"^"_$GET(^TMP("PSS50",$JOB,50,PSS(1),100,"E")))
+5 SET ^TMP($JOB,LIST,+PSS(1),101)=$GET(^TMP("PSS50",$JOB,50,PSS(1),101,"I"))
+6 QUIT
SFRMA ;
+1 SET ^TMP($JOB,LIST,+PSS(1),"FRM",+PSS(2),.01)=$SELECT($GET(^TMP("PSS50",$JOB,50.065,PSS(2),.01,"I"))="":"",1:$GET(^TMP("PSS50",$JOB,50.065,PSS(2),.01,"I"))_"^"_$GET(^TMP("PSS50",$JOB,50.065,PSS(2),.01,"E")))
+2 QUIT
LOOP ;
+1 NEW PSSENCT
+2 SET PSSENCT=0
+3 SET PSS(1)=0
FOR
SET PSS(1)=$ORDER(^PSDRUG(PSS(1)))
if 'PSS(1)
QUIT
Begin DoDot:1
+4 IF $PIECE($GET(^PSDRUG(PSS(1),0)),"^")=""
QUIT
+5 IF $GET(PSSFL)
IF $PIECE($GET(^PSDRUG(PSS(1),"I")),"^")
IF $PIECE($GET(^("I")),"^")'>PSSFL
QUIT
+6 IF $GET(PSSRTOI)=1
IF '$PIECE($GET(^PSDRUG(PSS(1),2)),"^")
QUIT
+7 ;Naked reference below refers to ^PSDRUG(PSS(1),2)
+8 IF $GET(PSSPK)]""
NEW PSSZ5,PSSZ6
SET PSSZ5=0
FOR PSSZ6=1:1:$LENGTH(PSSPK)
if PSSZ5
QUIT
IF $PIECE($GET(^(2)),"^",3)[$EXTRACT(PSSPK,PSSZ6)
SET PSSZ5=1
+9 IF $GET(PSSPK)]""
IF 'PSSZ5
QUIT
+10 DO SETSUB6^PSS50AQM(PSS(1))
+11 DO SCLOZ1
+12 SET PSSENCT=PSSENCT+1
End DoDot:1
+13 SET ^TMP($JOB,LIST,0)=$SELECT($GET(PSSENCT):$GET(PSSENCT),1:"-1^NO DATA FOUND")
+14 QUIT
SCLOZ1 ;
+1 NEW PSSZNODE
+2 SET PSSZNODE=$GET(^PSDRUG(PSS(1),0))
+3 SET ^TMP($JOB,LIST,+PSS(1),.01)=$PIECE(PSSZNODE,"^")
+4 SET ^TMP($JOB,LIST,"B",$PIECE(PSSZNODE,"^"),PSS(1))=""
+5 ;Set CLOZ2 multiple information
+6 NEW PSSCZPC
SET PSSCZPC=0
+7 IF $ORDER(^PSDRUG(PSS(1),"CLOZ2",0))
NEW PSSCZP,PSSCZP1
Begin DoDot:1
+8 FOR PSSCZP=0:0
SET PSSCZP=$ORDER(^PSDRUG(PSS(1),"CLOZ2",PSSCZP))
if 'PSSCZP
QUIT
Begin DoDot:2
+9 SET PSSCZP1=$GET(^PSDRUG(PSS(1),"CLOZ2",PSSCZP,0))
IF $PIECE(PSSCZP1,"^")'=""
SET PSSCZPC=PSSCZPC+1
Begin DoDot:3
+10 NEW PSSCARZ,DA,DR,DIC,DIQ
KILL PSSCARZ
SET DIC=50
SET DR="17.7"
SET DA=PSS(1)
SET DR(50.02)=".01;1;2;3"
SET DA(50.02)=PSSCZP
SET DIQ="PSSCARZ"
SET DIQ(0)="IE"
DO EN^DIQ1
+11 SET ^TMP($JOB,LIST,+PSS(1),"CLOZ",PSSCZP,.01)=$SELECT($GET(PSSCARZ(50.02,PSSCZP,.01,"I"))="":"",1:$GET(PSSCARZ(50.02,PSSCZP,.01,"I"))_"^"_$GET(PSSCARZ(50.02,PSSCZP,.01,"E")))
+12 SET ^TMP($JOB,LIST,+PSS(1),"CLOZ",PSSCZP,1)=$GET(PSSCARZ(50.02,PSSCZP,1,"I"))
+13 SET ^TMP($JOB,LIST,+PSS(1),"CLOZ",PSSCZP,2)=$SELECT($GET(PSSCARZ(50.02,PSSCZP,2,"I"))="":"",1:$GET(PSSCARZ(50.02,PSSCZP,2,"I"))_"^"_$GET(PSSCARZ(50.02,PSSCZP,2,"E")))
+14 SET ^TMP($JOB,LIST,+PSS(1),"CLOZ",PSSCZP,3)=$SELECT($GET(PSSCARZ(50.02,PSSCZP,3,"I"))="":"",1:$GET(PSSCARZ(50.02,PSSCZP,3,"I"))_"^"_$GET(PSSCARZ(50.02,PSSCZP,3,"E")))
End DoDot:3
End DoDot:2
End DoDot:1
+15 SET ^TMP($JOB,LIST,+PSS(1),"CLOZ",0)=$SELECT(PSSCZPC:PSSCZPC,1:"-1^NO DATA FOUND")
+16 QUIT
LOOP2 ;
+1 NEW PSSENCT,PSSIEN
+2 SET PSSENCT=0
+3 SET PSSIEN=0
FOR
SET PSSIEN=$ORDER(^PSDRUG(PSSIEN))
if 'PSSIEN
QUIT
Begin DoDot:1
+4 IF $PIECE($GET(^PSDRUG(PSSIEN,0)),"^")=""
QUIT
+5 IF $GET(PSSFL)
IF $PIECE($GET(^PSDRUG(PSSIEN,"I")),"^")
IF $PIECE($GET(^("I")),"^")'>PSSFL
QUIT
+6 ;Naked reference below refers to ^PSDRUG(PSSIEN,2)
+7 IF $GET(PSSPK)]""
NEW PSSZ5,PSSZ6
SET PSSZ5=0
FOR PSSZ6=1:1:$LENGTH(PSSPK)
if PSSZ5
QUIT
IF $PIECE($GET(^(2)),"^",3)[$EXTRACT(PSSPK,PSSZ6)
SET PSSZ5=1
+8 IF $GET(PSSPK)]""
IF 'PSSZ5
QUIT
+9 KILL ^TMP("PSS50",$JOB)
DO GETS^DIQ(50,+PSSIEN,".01;25;100;101;65*","IE","^TMP(""PSS50"",$J)")
SET PSS(1)=0
+10 FOR
SET PSS(1)=$ORDER(^TMP("PSS50",$JOB,50,PSS(1)))
if 'PSS(1)
QUIT
DO SFRM
Begin DoDot:2
+11 SET (PSS(2),PSSFRCT)=0
FOR
SET PSS(2)=$ORDER(^TMP("PSS50",$JOB,50.065,PSS(2)))
if 'PSS(2)
QUIT
SET PSSFRCT=PSSFRCT+1
DO SFRMA
+12 SET ^TMP($JOB,LIST,+PSS(1),"FRM",0)=$SELECT($GET(PSSFRCT):PSSFRCT,1:"-1^NO DATA FOUND")
End DoDot:2
+13 SET PSSENCT=PSSENCT+1
End DoDot:1
+14 SET ^TMP($JOB,LIST,0)=$SELECT($GET(PSSENCT):$GET(PSSENCT),1:"-1^NO DATA FOUND")
+15 KILL ^TMP("PSS50",$JOB)
+16 QUIT
