PSS50B2.m

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

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))