PSS50DAT ;BHAM ISC/TSS - CONTINUATION OF API FOR INFORMATION FROM FILE 50; 5 Sep 03
;;1.0;PHARMACY DATA MANAGEMENT;**85,92,112,118**;9/30/97;Build 8
DATA ;
;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.
;Reference to ^PSNDF(50.68 is supported by DBIA 3735
;NEW UNPROTECTED FILEMAN VARIABLES
N DO,DINDEX,DISUB,DIVAL
N PSSBGCNT
N PSSCNT
N PSSTIEN
N PSSTMP
N PSSOLD
N PSSALT
N PSSMATCH
N PSSSYN
N PSSCAP
S PSSBGCNT=0
S SCR("S")=""
I $G(LIST)']"" Q
I +$G(PSSIEN)'>0,($G(PSSFT)']"") S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
K ^TMP("DILIST",$J)
K ^TMP($J,LIST)
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) D COUNTBG Q
.I PSSIEN2>0 D DIRREAD
I +$G(PSSIEN)=0 D
.I PSSFT="??" D LOOPDIR D COUNTBG Q
.D FIND^DIC(50,,"@;.01","QP",PSSFT,,"B",SCR("S"),,"") D LOOPDI D COUNTBG
Q
;
COUNTBG ;CHECKS PSSBGCNT AND FILLS COUNT IN ON 0 NODE OF ^TMP($J,LIST)
I PSSBGCNT>0 D
.S ^TMP($J,LIST,0)=PSSBGCNT
ELSE S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND"
Q
;
LOOPDI ;LOOPS ON "DILIST" FROM FILEMAN CALL (USED FOR RETURNING MULTIPLE DRUGS FROM PSSFT)
S PSSTIEN=0 ;TEMP IEN TO ITERATE OVER DILIST
F S PSSTIEN=$O(^TMP("DILIST",$J,PSSTIEN)) Q:PSSTIEN="" D
.S PSSIEN2=($P(^TMP("DILIST",$J,PSSTIEN,0),U,1))
.D DIRREAD
Q
;
LOOPDIR ;LOOP FOR A DIRECT READ. READS ALL IENs FOR ^PSDRUG(
S PSSIEN2=0
F S PSSIEN2=$O(^PSDRUG(PSSIEN2)) Q:'PSSIEN2 D
.I $P($G(^PSDRUG(PSSIEN2,0)),U,1)'="" D DIRALL
Q
;
DIRALL ;TEST FOR PSSFL, PSSRTOI, PSSPK, BAILS IF CONDITIONS MEET TRUE
I $G(PSSFL),$P($G(^PSDRUG(PSSIEN2,"I")),"^"),$P($G(^("I")),"^")'>PSSFL Q
I $G(PSSRTOI)=1,'$P($G(^PSDRUG(PSSIEN2,2)),"^") Q
I $G(PSSPK)]"" N PSSZ5,PSSZ6 S PSSZ5=0 F PSSZ6=1:1:$L(PSSPK) Q:PSSZ5 I $P($G(^PSDRUG(PSSIEN2,2)),U,3)[$E(PSSPK,PSSZ6) S PSSZ5=1
I $G(PSSPK)]"",'PSSZ5 Q
D DIRREAD
Q
;
DIRREAD ;MAIN DIRECT READ FOR ENTIRE ROUTINE
D DIRREAD^PSS50TMP
D SYNONYM
S ^TMP($J,LIST,"B",$G(^TMP($J,LIST,PSSIEN2,.01)),PSSIEN2)=""
D FORMALT
D OLD
D SRVCODE($P(^TMP($J,LIST,PSSIEN2,22),U,1))
S PSSBGCNT=PSSBGCNT+1
Q
;
SYNONYM ; FILLS SYNONYM MULTIPLE
S PSSCNT=0
S PSSTMP=""
S PSSSYN=""
F S PSSSYN=$O(^PSDRUG(PSSIEN2,1,PSSSYN)) Q:PSSSYN="" D
.I $P($G(^PSDRUG(PSSIEN2,1,PSSSYN,0)),U,1)'="" D
..S ^TMP($J,LIST,PSSIEN2,"SYN",PSSSYN,.01)=$P($G(^PSDRUG(PSSIEN2,1,PSSSYN,0)),U,1)
..;;;;;INTENDED USE
..S PSSTMP=$P($G(^PSDRUG(PSSIEN2,1,PSSSYN,0)),U,3)
..I PSSTMP="0" S ^TMP($J,LIST,PSSIEN2,"SYN",PSSSYN,1)=PSSTMP_U_"TRADE NAME"
..I PSSTMP="1" S ^TMP($J,LIST,PSSIEN2,"SYN",PSSSYN,1)=PSSTMP_U_"QUICK CODE"
..I PSSTMP="D" S ^TMP($J,LIST,PSSIEN2,"SYN",PSSSYN,1)=PSSTMP_U_"DRUG ACCOUNTABILITY"
..I PSSTMP="C" S ^TMP($J,LIST,PSSIEN2,"SYN",PSSSYN,1)=PSSTMP_U_"CONTROLLED SUBSTANCES"
..I PSSTMP="" S ^TMP($J,LIST,PSSIEN2,"SYN",PSSSYN,1)=""
..;;;;;NDC CODE
..S ^TMP($J,LIST,PSSIEN2,"SYN",PSSSYN,2)=$P($G(^PSDRUG(PSSIEN2,1,PSSSYN,0)),U,2)
..S ^TMP($J,LIST,PSSIEN2,"SYN",PSSSYN,403)=$P($G(^PSDRUG(PSSIEN2,1,PSSSYN,0)),U,7)
..S PSSCNT=PSSCNT+1
I PSSCNT=0 S ^TMP($J,LIST,PSSIEN2,"SYN",0)="-1^NO DATA FOUND"
ELSE S ^TMP($J,LIST,PSSIEN2,"SYN",0)=PSSCNT
Q
;
FORMALT ;FILLS FORMULARY ALTERATIVE MULTIPLE
S PSSCNT=0
S PSSALT=0
F S PSSALT=$O(^PSDRUG(PSSIEN2,65,PSSALT)) Q:PSSALT="" D
.I $P($G(^PSDRUG(PSSIEN2,65,PSSALT,0)),U,1)'="" D
..S ^TMP($J,LIST,PSSIEN2,"FRM",PSSALT,2)=$P($G(^PSDRUG(PSSIEN2,65,PSSALT,0)),U,1)_U_$P($G(^PSDRUG($P($G(^PSDRUG(PSSIEN2,65,PSSALT,0)),U,1),0)),U,1)
..S PSSCNT=PSSCNT+1
I PSSCNT=0 S ^TMP($J,LIST,PSSIEN2,"FRM",0)="-1^NO DATA FOUND"
ELSE S ^TMP($J,LIST,PSSIEN2,"FRM",0)=PSSCNT
Q
;
OLD ;FILLS THE OLD NAME MULTIPLE
S PSSCNT=0
S PSSOLD=0
F S PSSOLD=$O(^PSDRUG(PSSIEN2,900,PSSOLD)) Q:PSSOLD="" D
.I $P($G(^PSDRUG(PSSIEN2,900,PSSOLD,0)),U,2)'="" D
..S PSSCAP=$$UP^XLFSTR($$FMTE^XLFDT($P(^PSDRUG(PSSIEN2,900,PSSOLD,0),U,2)))
..S ^TMP($J,LIST,PSSIEN2,"OLD",PSSOLD,.02)=$P($G(^PSDRUG(PSSIEN2,900,PSSOLD,0)),U,2)_U_PSSCAP
.ELSE S ^TMP($J,LIST,PSSIEN2,"OLD",PSSOLD,.02)=""
.I $P($G(^PSDRUG(PSSIEN2,900,PSSOLD,0)),U,1)'="" D
..S ^TMP($J,LIST,PSSIEN2,"OLD",PSSOLD,.01)=$P($G(^PSDRUG(PSSIEN2,900,PSSOLD,0)),U,1)
..S PSSCNT=PSSCNT+1
.ELSE S ^TMP($J,LIST,PSSIEN2,"OLD",PSSOLD,.01)=""
I PSSCNT=0 S ^TMP($J,LIST,PSSIEN2,"OLD",0)="-1^NO DATA FOUND"
ELSE S ^TMP($J,LIST,PSSIEN2,"OLD",0)=PSSCNT
Q
;
SRVCODE(PSSMATCH) ;FILLS SERVICE CODE MULTIPLE
I PSSMATCH'="" S ^TMP($J,LIST,PSSIEN2,400)=$P($G(^PSNDF(50.68,PSSMATCH,"PFS")),U,1)
I $P($G(^TMP($J,LIST,PSSIEN2,400)),U,1)="" S ^TMP($J,LIST,PSSIEN2,400)=$P($G(^PSDRUG(PSSIEN2,"PFS")),U,1)
I $P($G(^TMP($J,LIST,PSSIEN2,400)),U,1)="" S ^TMP($J,LIST,PSSIEN2,400)=600000
Q
;
DRG ;
;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;62.01:62.05;905","IE","^TMP(""PSSP50"",$J)") S PSS(1)=0
.F S PSS(1)=$O(^TMP("PSSP50",$J,50,PSS(1))) Q:'PSS(1) D SETDRG^PSS50A1
I $G(PSSIEN)'="" S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
I $G(PSSFT)]"" D
.I PSSFT["??" D LOOP^PSS50A1 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;62.01:62.05;905","IE","^TMP(""PSSP50"",$J)") S PSS(1)=0
..F S PSS(1)=$O(^TMP("PSSP50",$J,50,PSS(1))) Q:'PSS(1) D SETDRG^PSS50A1
K ^TMP("DILIST",$J),^TMP("PSSP50",$J)
Q
;
LOOP ;
N PSS50DD1,PSS50DD2,PSS50DD3,PSS50DD4,PSS50ER1,PSS50ER2,PSS50ER3,PSS50ER4,PSS51NFD,PSS52NFD,PSSG2N,PSS501NX
D FIELD^DID(50,51,"Z","POINTER","PSS50DD1","PSS50ER1") S PSS51NFD=$G(PSS50DD1("POINTER"))
D FIELD^DID(50,52,"Z","POINTER","PSS50DD2","PSS50ER2") S PSS52NFD=$G(PSS50DD2("POINTER"))
D FIELD^DID(50,301,"Z","POINTER","PSS50DD3","PSS50ER3") S PSSG2N=$G(PSS50DD3("POINTER"))
D FIELD^DID(50.1,1,"Z","POINTER","PSS50DD4","PSS50ER4") S PSS501NX=$G(PSS50DD4("POINTER"))
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 SETSUB1^PSS50AQM(PSS(1)),SETSUB2^PSS50AQM(PSS(1)),SETSUB3^PSS50AQM(PSS(1))
.D SETALL^PSS50AQM,SETOLD^PSS50AQM,SETSYN^PSS50AQM,SETFMA^PSS50AQM
.S PSSENCT=PSSENCT+1
S ^TMP($J,LIST,0)=$S($G(PSSENCT):$G(PSSENCT),1:"-1^NO DATA FOUND")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSS50DAT 8789 printed Apr 09, 2024@21:37:12 Page 2
PSS50DAT ;BHAM ISC/TSS - CONTINUATION OF API FOR INFORMATION FROM FILE 50; 5 Sep 03
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**85,92,112,118**;9/30/97;Build 8
DATA ;
+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 ;Reference to ^PSNDF(50.68 is supported by DBIA 3735
+12 ;NEW UNPROTECTED FILEMAN VARIABLES
+13 NEW DO,DINDEX,DISUB,DIVAL
+14 NEW PSSBGCNT
+15 NEW PSSCNT
+16 NEW PSSTIEN
+17 NEW PSSTMP
+18 NEW PSSOLD
+19 NEW PSSALT
+20 NEW PSSMATCH
+21 NEW PSSSYN
+22 NEW PSSCAP
+23 SET PSSBGCNT=0
+24 SET SCR("S")=""
+25 IF $GET(LIST)']""
QUIT
+26 IF +$GET(PSSIEN)'>0
IF ($GET(PSSFT)']"")
SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
QUIT
+27 KILL ^TMP("DILIST",$JOB)
+28 KILL ^TMP($JOB,LIST)
+29 SET SCR("S")=""
+30 IF +$GET(PSSFL)>0!($GET(PSSPK)]"")!($GET(PSSRTOI)=1)
NEW PSS5ND,PSSZ3,PSSZ4
DO SETSCRN^PSS50A
+31 IF +$GET(PSSIEN)>0
NEW PSSIEN2
SET PSSIEN2=$$FIND1^DIC(50,"","A","`"_PSSIEN,,SCR("S"),"")
Begin DoDot:1
+32 IF PSSIEN2>0
DO DIRREAD
End DoDot:1
KILL ^TMP("PSSP50",$JOB)
DO COUNTBG
QUIT
+33 IF +$GET(PSSIEN)=0
Begin DoDot:1
+34 IF PSSFT="??"
DO LOOPDIR
DO COUNTBG
QUIT
+35 DO FIND^DIC(50,,"@;.01","QP",PSSFT,,"B",SCR("S"),,"")
DO LOOPDI
DO COUNTBG
End DoDot:1
+36 QUIT
+37 ;
COUNTBG ;CHECKS PSSBGCNT AND FILLS COUNT IN ON 0 NODE OF ^TMP($J,LIST)
+1 IF PSSBGCNT>0
Begin DoDot:1
+2 SET ^TMP($JOB,LIST,0)=PSSBGCNT
End DoDot:1
+3 IF '$TEST
SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
+4 QUIT
+5 ;
LOOPDI ;LOOPS ON "DILIST" FROM FILEMAN CALL (USED FOR RETURNING MULTIPLE DRUGS FROM PSSFT)
+1 ;TEMP IEN TO ITERATE OVER DILIST
SET PSSTIEN=0
+2 FOR
SET PSSTIEN=$ORDER(^TMP("DILIST",$JOB,PSSTIEN))
if PSSTIEN=""
QUIT
Begin DoDot:1
+3 SET PSSIEN2=($PIECE(^TMP("DILIST",$JOB,PSSTIEN,0),U,1))
+4 DO DIRREAD
End DoDot:1
+5 QUIT
+6 ;
LOOPDIR ;LOOP FOR A DIRECT READ. READS ALL IENs FOR ^PSDRUG(
+1 SET PSSIEN2=0
+2 FOR
SET PSSIEN2=$ORDER(^PSDRUG(PSSIEN2))
if 'PSSIEN2
QUIT
Begin DoDot:1
+3 IF $PIECE($GET(^PSDRUG(PSSIEN2,0)),U,1)'=""
DO DIRALL
End DoDot:1
+4 QUIT
+5 ;
DIRALL ;TEST FOR PSSFL, PSSRTOI, PSSPK, BAILS IF CONDITIONS MEET TRUE
+1 IF $GET(PSSFL)
IF $PIECE($GET(^PSDRUG(PSSIEN2,"I")),"^")
IF $PIECE($GET(^("I")),"^")'>PSSFL
QUIT
+2 IF $GET(PSSRTOI)=1
IF '$PIECE($GET(^PSDRUG(PSSIEN2,2)),"^")
QUIT
+3 IF $GET(PSSPK)]""
NEW PSSZ5,PSSZ6
SET PSSZ5=0
FOR PSSZ6=1:1:$LENGTH(PSSPK)
if PSSZ5
QUIT
IF $PIECE($GET(^PSDRUG(PSSIEN2,2)),U,3)[$EXTRACT(PSSPK,PSSZ6)
SET PSSZ5=1
+4 IF $GET(PSSPK)]""
IF 'PSSZ5
QUIT
+5 DO DIRREAD
+6 QUIT
+7 ;
DIRREAD ;MAIN DIRECT READ FOR ENTIRE ROUTINE
+1 DO DIRREAD^PSS50TMP
+2 DO SYNONYM
+3 SET ^TMP($JOB,LIST,"B",$GET(^TMP($JOB,LIST,PSSIEN2,.01)),PSSIEN2)=""
+4 DO FORMALT
+5 DO OLD
+6 DO SRVCODE($PIECE(^TMP($JOB,LIST,PSSIEN2,22),U,1))
+7 SET PSSBGCNT=PSSBGCNT+1
+8 QUIT
+9 ;
SYNONYM ; FILLS SYNONYM MULTIPLE
+1 SET PSSCNT=0
+2 SET PSSTMP=""
+3 SET PSSSYN=""
+4 FOR
SET PSSSYN=$ORDER(^PSDRUG(PSSIEN2,1,PSSSYN))
if PSSSYN=""
QUIT
Begin DoDot:1
+5 IF $PIECE($GET(^PSDRUG(PSSIEN2,1,PSSSYN,0)),U,1)'=""
Begin DoDot:2
+6 SET ^TMP($JOB,LIST,PSSIEN2,"SYN",PSSSYN,.01)=$PIECE($GET(^PSDRUG(PSSIEN2,1,PSSSYN,0)),U,1)
+7 ;;;;;INTENDED USE
+8 SET PSSTMP=$PIECE($GET(^PSDRUG(PSSIEN2,1,PSSSYN,0)),U,3)
+9 IF PSSTMP="0"
SET ^TMP($JOB,LIST,PSSIEN2,"SYN",PSSSYN,1)=PSSTMP_U_"TRADE NAME"
+10 IF PSSTMP="1"
SET ^TMP($JOB,LIST,PSSIEN2,"SYN",PSSSYN,1)=PSSTMP_U_"QUICK CODE"
+11 IF PSSTMP="D"
SET ^TMP($JOB,LIST,PSSIEN2,"SYN",PSSSYN,1)=PSSTMP_U_"DRUG ACCOUNTABILITY"
+12 IF PSSTMP="C"
SET ^TMP($JOB,LIST,PSSIEN2,"SYN",PSSSYN,1)=PSSTMP_U_"CONTROLLED SUBSTANCES"
+13 IF PSSTMP=""
SET ^TMP($JOB,LIST,PSSIEN2,"SYN",PSSSYN,1)=""
+14 ;;;;;NDC CODE
+15 SET ^TMP($JOB,LIST,PSSIEN2,"SYN",PSSSYN,2)=$PIECE($GET(^PSDRUG(PSSIEN2,1,PSSSYN,0)),U,2)
+16 SET ^TMP($JOB,LIST,PSSIEN2,"SYN",PSSSYN,403)=$PIECE($GET(^PSDRUG(PSSIEN2,1,PSSSYN,0)),U,7)
+17 SET PSSCNT=PSSCNT+1
End DoDot:2
End DoDot:1
+18 IF PSSCNT=0
SET ^TMP($JOB,LIST,PSSIEN2,"SYN",0)="-1^NO DATA FOUND"
+19 IF '$TEST
SET ^TMP($JOB,LIST,PSSIEN2,"SYN",0)=PSSCNT
+20 QUIT
+21 ;
FORMALT ;FILLS FORMULARY ALTERATIVE MULTIPLE
+1 SET PSSCNT=0
+2 SET PSSALT=0
+3 FOR
SET PSSALT=$ORDER(^PSDRUG(PSSIEN2,65,PSSALT))
if PSSALT=""
QUIT
Begin DoDot:1
+4 IF $PIECE($GET(^PSDRUG(PSSIEN2,65,PSSALT,0)),U,1)'=""
Begin DoDot:2
+5 SET ^TMP($JOB,LIST,PSSIEN2,"FRM",PSSALT,2)=$PIECE($GET(^PSDRUG(PSSIEN2,65,PSSALT,0)),U,1)_U_$PIECE($GET(^PSDRUG($PIECE($GET(^PSDRUG(PSSIEN2,65,PSSALT,0)),U,1),0)),U,1)
+6 SET PSSCNT=PSSCNT+1
End DoDot:2
End DoDot:1
+7 IF PSSCNT=0
SET ^TMP($JOB,LIST,PSSIEN2,"FRM",0)="-1^NO DATA FOUND"
+8 IF '$TEST
SET ^TMP($JOB,LIST,PSSIEN2,"FRM",0)=PSSCNT
+9 QUIT
+10 ;
OLD ;FILLS THE OLD NAME MULTIPLE
+1 SET PSSCNT=0
+2 SET PSSOLD=0
+3 FOR
SET PSSOLD=$ORDER(^PSDRUG(PSSIEN2,900,PSSOLD))
if PSSOLD=""
QUIT
Begin DoDot:1
+4 IF $PIECE($GET(^PSDRUG(PSSIEN2,900,PSSOLD,0)),U,2)'=""
Begin DoDot:2
+5 SET PSSCAP=$$UP^XLFSTR($$FMTE^XLFDT($PIECE(^PSDRUG(PSSIEN2,900,PSSOLD,0),U,2)))
+6 SET ^TMP($JOB,LIST,PSSIEN2,"OLD",PSSOLD,.02)=$PIECE($GET(^PSDRUG(PSSIEN2,900,PSSOLD,0)),U,2)_U_PSSCAP
End DoDot:2
+7 IF '$TEST
SET ^TMP($JOB,LIST,PSSIEN2,"OLD",PSSOLD,.02)=""
+8 IF $PIECE($GET(^PSDRUG(PSSIEN2,900,PSSOLD,0)),U,1)'=""
Begin DoDot:2
+9 SET ^TMP($JOB,LIST,PSSIEN2,"OLD",PSSOLD,.01)=$PIECE($GET(^PSDRUG(PSSIEN2,900,PSSOLD,0)),U,1)
+10 SET PSSCNT=PSSCNT+1
End DoDot:2
+11 IF '$TEST
SET ^TMP($JOB,LIST,PSSIEN2,"OLD",PSSOLD,.01)=""
End DoDot:1
+12 IF PSSCNT=0
SET ^TMP($JOB,LIST,PSSIEN2,"OLD",0)="-1^NO DATA FOUND"
+13 IF '$TEST
SET ^TMP($JOB,LIST,PSSIEN2,"OLD",0)=PSSCNT
+14 QUIT
+15 ;
SRVCODE(PSSMATCH) ;FILLS SERVICE CODE MULTIPLE
+1 IF PSSMATCH'=""
SET ^TMP($JOB,LIST,PSSIEN2,400)=$PIECE($GET(^PSNDF(50.68,PSSMATCH,"PFS")),U,1)
+2 IF $PIECE($GET(^TMP($JOB,LIST,PSSIEN2,400)),U,1)=""
SET ^TMP($JOB,LIST,PSSIEN2,400)=$PIECE($GET(^PSDRUG(PSSIEN2,"PFS")),U,1)
+3 IF $PIECE($GET(^TMP($JOB,LIST,PSSIEN2,400)),U,1)=""
SET ^TMP($JOB,LIST,PSSIEN2,400)=600000
+4 QUIT
+5 ;
DRG ;
+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;62.01:62.05;905","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 SETDRG^PSS50A1
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^PSS50A1
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;62.01:62.05;905","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 SETDRG^PSS50A1
End DoDot:2
End DoDot:1
+33 KILL ^TMP("DILIST",$JOB),^TMP("PSSP50",$JOB)
+34 QUIT
+35 ;
LOOP ;
+1 NEW PSS50DD1,PSS50DD2,PSS50DD3,PSS50DD4,PSS50ER1,PSS50ER2,PSS50ER3,PSS50ER4,PSS51NFD,PSS52NFD,PSSG2N,PSS501NX
+2 DO FIELD^DID(50,51,"Z","POINTER","PSS50DD1","PSS50ER1")
SET PSS51NFD=$GET(PSS50DD1("POINTER"))
+3 DO FIELD^DID(50,52,"Z","POINTER","PSS50DD2","PSS50ER2")
SET PSS52NFD=$GET(PSS50DD2("POINTER"))
+4 DO FIELD^DID(50,301,"Z","POINTER","PSS50DD3","PSS50ER3")
SET PSSG2N=$GET(PSS50DD3("POINTER"))
+5 DO FIELD^DID(50.1,1,"Z","POINTER","PSS50DD4","PSS50ER4")
SET PSS501NX=$GET(PSS50DD4("POINTER"))
+6 NEW PSSENCT
+7 SET PSSENCT=0
+8 SET PSS(1)=0
FOR
SET PSS(1)=$ORDER(^PSDRUG(PSS(1)))
if 'PSS(1)
QUIT
Begin DoDot:1
+9 IF $PIECE($GET(^PSDRUG(PSS(1),0)),"^")=""
QUIT
+10 IF $GET(PSSFL)
IF $PIECE($GET(^PSDRUG(PSS(1),"I")),"^")
IF $PIECE($GET(^("I")),"^")'>PSSFL
QUIT
+11 IF $GET(PSSRTOI)=1
IF '$PIECE($GET(^PSDRUG(PSS(1),2)),"^")
QUIT
+12 ;Naked reference below refers to ^PSDRUG(PSS(1),2)
+13 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
+14 IF $GET(PSSPK)]""
IF 'PSSZ5
QUIT
+15 DO SETSUB1^PSS50AQM(PSS(1))
DO SETSUB2^PSS50AQM(PSS(1))
DO SETSUB3^PSS50AQM(PSS(1))
+16 DO SETALL^PSS50AQM
DO SETOLD^PSS50AQM
DO SETSYN^PSS50AQM
DO SETFMA^PSS50AQM
+17 SET PSSENCT=PSSENCT+1
End DoDot:1
+18 SET ^TMP($JOB,LIST,0)=$SELECT($GET(PSSENCT):$GET(PSSENCT),1:"-1^NO DATA FOUND")
+19 QUIT
