PSS50F1 ;BIR/RTR - API FOR INFORMATION FROM FILE 50
;;1.0;PHARMACY DATA MANAGEMENT;**85**;9/30/97
;
;Reference to ^PS(50.605 is supported by DBIA #2138
;
LIST ;
;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.
;PSSD - Index used in the lookup in the format B^C
;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,PSSP50,SCR,PSS,CNT,PSSXSUB,PSSLUPAR,PSSLUPP,PSSSCRN,PSSENCT
I $G(LIST)']"" Q
K ^TMP($J,LIST)
I $G(PSSFT)']"" S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
S SCR("S")=""
S PSSXSUB="" D SETXSUB
S PSSENCT=0
I +$G(PSSFL)>0!($G(PSSPK)]"") N PSS5ND,PSSZ3,PSSZ4 D SETSCRN^PSS50A
I $G(PSSFT)]"" D
.I PSSFT["??" D LOOP Q
.K ^TMP("DILIST",$J),^TMP($J,"PSSLDONE")
.S PSSSCRN=$G(SCR("S")) S:$G(PSSD)="" PSSD="B" D PARSE^PSS50F(PSSD) I '$O(PSSLUPAR(0)) Q
.S PSSLUPP=0 F S PSSLUPP=$O(PSSLUPAR(PSSLUPP)) Q:'PSSLUPP D
..S SCR("S")=$G(PSSSCRN)
..D FIND^DIC(50,,"@;.01","QPB"_$S($P(PSSLUPAR(PSSLUPP),"^",2):"X",1:""),PSSFT,,PSSLUPAR(PSSLUPP),SCR("S"),,"")
..I +$G(^TMP("DILIST",$J,0))=0 Q
..I +^TMP("DILIST",$J,0)>0 N PSSXX S PSSXX=0 F S PSSXX=$O(^TMP("DILIST",$J,PSSXX)) Q:'PSSXX D
...S PSSIEN=+^TMP("DILIST",$J,PSSXX,0) I '$D(^TMP($J,"PSSLDONE",PSSIEN)) S ^TMP($J,"PSSLDONE",PSSIEN)="" D
....K ^TMP("PSSP50",$J) D GETS^DIQ(50,+PSSIEN,".01;100;2.1","IE","^TMP(""PSSP50"",$J)") S PSS(1)=0
....F S PSS(1)=$O(^TMP("PSSP50",$J,50,PSS(1))) Q:'PSS(1) D SETLIST
S ^TMP($J,LIST,0)=$S($G(PSSENCT):$G(PSSENCT),1:"-1^NO DATA FOUND")
K ^TMP("DILIST",$J),^TMP("PSSP50",$J),^TMP($J,"PSSLDONE")
Q
SETLIST ;
S PSSENCT=PSSENCT+1
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))=""
;S ^TMP($J,LIST,$S($G(PSSD)]"":$P(PSSD,"^"),1:"B"),^TMP("PSSP50",$J,50,PSS(1),.01,"I"),+PSS(1))=""
S ^TMP($J,LIST,$S($G(PSSXSUB)'="":$G(PSSXSUB),1:"B"),^TMP("PSSP50",$J,50,PSS(1),.01,"I"),+PSS(1))=""
S ^TMP($J,LIST,+PSS(1),2.1)=$S($G(^TMP("PSSP50",$J,50,PSS(1),2.1,"I"))="":"",1:$G(^TMP("PSSP50",$J,50,PSS(1),2.1,"I"))_"^"_$G(^TMP("PSSP50",$J,50,PSS(1),2.1,"E")))
I $P($G(^TMP($J,LIST,+PSS(1),2.1)),"^") D
.N PSSADDF S PSSADDF=$$SETDF^PSS50AQM($P(^TMP($J,LIST,+PSS(1),2.1),"^")) S ^TMP($J,LIST,+PSS(1),2.1)=^TMP($J,LIST,+PSS(1),2.1)_$S($P($G(PSSADDF),"^")>0:"^"_$P($G(PSSADDF),"^",3)_"^"_$P($G(PSSADDF),"^",4),1:"")
S ^TMP($J,LIST,+PSS(1),100)=$S($G(^TMP("PSSP50",$J,50,PSS(1),100,"I"))="":"",1:$G(^TMP("PSSP50",$J,50,PSS(1),100,"I"))_"^"_$G(^TMP("PSSP50",$J,50,PSS(1),100,"E")))
Q
LOOP ;
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 SETLISTL
.S PSSENCT=PSSENCT+1
Q
SETLISTL ;
N PSSZNODE,PSS2NODE S PSSZNODE=$G(^PSDRUG(PSS(1),0)),PSS2NODE=$G(^(2))
S ^TMP($J,LIST,+PSS(1),.01)=$P(PSSZNODE,"^")
S ^TMP($J,LIST,"B",$P(PSSZNODE,"^"),+PSS(1))=""
S ^TMP($J,LIST,+PSS(1),2.1)=$S('$P(PSS2NODE,"^"):"",1:$P(PSS2NODE,"^")_"^"_$P($G(^PS(50.7,+$P(PSS2NODE,"^"),0)),"^"))
N PSSADDF S PSSADDF=$P($G(^PS(50.7,+$P($G(^TMP($J,LIST,+PSS(1),2.1)),"^"),0)),"^",2) I PSSADDF>0 D
.S ^TMP($J,LIST,+PSS(1),2.1)=^TMP($J,LIST,+PSS(1),2.1)_"^"_PSSADDF_"^"_$P($G(^PS(50.606,PSSADDF,0)),"^")
N Y S Y=$P($G(^PSDRUG(PSS(1),"I")),"^") D
.I Y S ^TMP($J,LIST,+PSS(1),100)=$G(Y) X ^DD("DD") S ^TMP($J,LIST,+PSS(1),100)=^TMP($J,LIST,+PSS(1),100)_"^"_$G(Y) Q
.S ^TMP($J,LIST,+PSS(1),100)=""
Q
SETXSUB ;
Q:$G(PSSD)=""
N PSSLSX,PSSLSXCT,PSSLCNT,PSSDSUB
S PSSLSXCT=0
F PSSLSX=1:1:$L(PSSD) I $E(PSSD,PSSLSX)="^" S PSSLSXCT=PSSLSXCT+1
S PSSLSXCT=PSSLSXCT+1
S PSSLCNT=0 F PSSLSX=1:1:PSSLSXCT S PSSDSUB=$P(PSSD,"^",PSSLSX) Q:PSSLCNT>1 S PSSXSUB=$S(PSSDSUB'="":PSSDSUB,PSSXSUB'="":PSSXSUB,1:"") S:PSSDSUB'="" PSSLCNT=PSSLCNT+1
I PSSLCNT>1 S PSSXSUB=""
Q
LOOKUP ;
;PSSFT - Free Text value that could be the NAME field (#.01), IEN, VA PRODUCT NAME field (#21), NATIONAL DRUG CLASS field (#25),
; or SYNONYM (#.01) mutiple of the DRUG file (#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 - 1 - only drugs with data in the PHARMACY ORDERABLE ITEM field (#2.1) will be returned.
;PSSIFCAP - 1 - only drugs with no data in the IFCAP ITEM NUMBER multiple (#441) will be returned.
;PSSCMOP - 1 - only drugs with no data in the CMOP ID field (#27) will be returned.
;PSSD - Index used in the lookup in the format B^C.
;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 PSSLKIEN,PSSLKSUB,PSSENCT,SCR,PSSXSUB,CNT,PSS,DIERR
I $G(LIST)']"" Q
K ^TMP($J,LIST)
I $G(PSSFT)']"" S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
S PSSENCT=0
I PSSFT["??" D LOOPLK Q
S SCR("S")=""
I $G(PSSCMOP)=1 D
.S SCR("S")="I $P($G(^(""ND"")),""^"",10)=""""" Q
I $G(PSSIFCAP)=1 D
.I SCR("S")="" S SCR("S")="I '$O(^PSDRUG(+Y,441,0))" Q
.S SCR("S")=SCR("S")_" I '$O(^PSDRUG(+Y,441,0))"
I +$G(PSSFL)>0!($G(PSSPK)]"")!($G(PSSRTOI)=1) N PSS5ND,PSSZ3,PSSZ4 D SETSCRN
I PSSFT'="",PSSFT?1"`"1N.N D S ^TMP($J,LIST,0)=$S($G(PSSENCT):$G(PSSENCT),1:"-1^NO DATA FOUND") Q
.N PSSIEN2 S PSSIEN2=$$FIND1^DIC(50,"","A",PSSFT,,SCR("S"),"")
.K ^TMP("DIERR",$J)
.I +PSSIEN2'>0 Q
.I $P($G(^PSDRUG(+PSSIEN2,0)),"^")="" Q
.S PSSLKIEN=+PSSIEN2,PSSLKSUB="B"
.D LOOKSET
I $G(PSSFT)]"" D
.N PSSLUPAR,PSSLUPP,PSSSCRN
.S PSSXSUB="" D SETXSUB S PSSLKSUB=$S($G(PSSXSUB)'="":$G(PSSXSUB),1:"B")
.K ^TMP("DILIST",$J),^TMP($J,"PSSLDONE")
.S PSSSCRN=$G(SCR("S")) S:$G(PSSD)="" PSSD="B" D PARSE^PSS50F(PSSD) I '$O(PSSLUPAR(0)) Q
.S PSSLUPP=0 F S PSSLUPP=$O(PSSLUPAR(PSSLUPP)) Q:'PSSLUPP D
..S SCR("S")=PSSSCRN
..D FIND^DIC(50,,"@;.01","QPB"_$S($P(PSSLUPAR(PSSLUPP),"^",2):"X",1:""),PSSFT,,PSSLUPAR(PSSLUPP),SCR("S"),,"")
..I +$G(^TMP("DILIST",$J,0))=0 Q
..I +^TMP("DILIST",$J,0)>0 N PSSXX S PSSXX=0 F S PSSXX=$O(^TMP("DILIST",$J,PSSXX)) Q:'PSSXX D
...S PSSLKIEN=+^TMP("DILIST",$J,PSSXX,0) I $P($G(^PSDRUG(PSSLKIEN,0)),"^")'="",'$D(^TMP($J,"PSSLDONE",PSSLKIEN)) S ^TMP($J,"PSSLDONE",PSSLKIEN)="" D LOOKSET
S ^TMP($J,LIST,0)=$S($G(PSSENCT):$G(PSSENCT),1:"-1^NO DATA FOUND")
K ^TMP("DILIST",$J),^TMP($J,"PSSLDONE")
Q
LOOKSET ;
;PSSLKIEN = ien from File 50
;PSSLKSUB = Subscript for the cross reference return
N PSSLKNAM,PSSLKND,PSSLKZER
S PSSLKNAM=$P($G(^PSDRUG(PSSLKIEN,0)),"^"),PSSLKND=$G(^("ND")),PSSLKZER=$G(^(0)) Q:PSSLKNAM=""
S ^TMP($J,LIST,PSSLKIEN,.01)=PSSLKNAM
S ^TMP($J,LIST,PSSLKSUB,PSSLKNAM,PSSLKIEN)=""
S PSSENCT=PSSENCT+1
S ^TMP($J,LIST,PSSLKIEN,25)=$S($P(PSSLKND,"^",6):$P(PSSLKND,"^",6)_"^"_$P($G(^PS(50.605,+$P(PSSLKND,"^",6),0)),"^")_"^"_$P($G(^(0)),"^",2),1:"")
N Y S Y=$P($G(^PSDRUG(PSSLKIEN,"I")),"^") D
.I Y S ^TMP($J,LIST,PSSLKIEN,100)=$G(Y) X ^DD("DD") S ^TMP($J,LIST,PSSLKIEN,100)=^TMP($J,LIST,PSSLKIEN,100)_"^"_$G(Y) Q
.S ^TMP($J,LIST,PSSLKIEN,100)=""
S ^TMP($J,LIST,PSSLKIEN,101)=$P(PSSLKZER,"^",10)
Q
LOOPLK ;
S PSSLKSUB="B"
S PSSLKIEN=0 F S PSSLKIEN=$O(^PSDRUG(PSSLKIEN)) Q:'PSSLKIEN D
.I $P($G(^PSDRUG(PSSLKIEN,0)),"^")="" Q
.I $G(PSSCMOP)=1,$P($G(^PSDRUG(PSSLKIEN,"ND")),"^",10)'="" Q
.I $G(PSSIFCAP)=1,$O(^PSDRUG(PSSLKIEN,441,0)) Q
.I $G(PSSFL),$P($G(^PSDRUG(PSSLKIEN,"I")),"^"),$P($G(^("I")),"^")'>PSSFL Q
.I $G(PSSRTOI)=1,'$P($G(^PSDRUG(PSSLKIEN,2)),"^") Q
.I $G(PSSPK)]"" N PSSZ5,PSSZ6 S PSSZ5=0 F PSSZ6=1:1:$L(PSSPK) Q:PSSZ5 I $P($G(^PSDRUG(PSSLKIEN,2)),"^",3)[$E(PSSPK,PSSZ6) S PSSZ5=1
.I $G(PSSPK)]"",'PSSZ5 Q
.D LOOKSET
S ^TMP($J,LIST,0)=$S($G(PSSENCT):$G(PSSENCT),1:"-1^NO DATA FOUND")
Q
;
SETSCRN ;Set Screen
I +$G(PSSFL)>0 D
.I SCR("S")]"" S SCR("S")=SCR("S")_" S PSS5ND=$P($G(^PSDRUG(+Y,""I"")),""^"") I PSS5ND=""""!(PSS5ND>PSSFL)" Q
.S SCR("S")="S PSS5ND=$P($G(^PSDRUG(+Y,""I"")),""^"") I PSS5ND=""""!(PSS5ND>PSSFL)"
I $G(PSSRTOI)=1 D
.I SCR("S")]"" S SCR("S")=SCR("S")_" I $P($G(^PSDRUG(+Y,2)),""^"")" Q
.S SCR("S")="I $P($G(^PSDRUG(+Y,2)),""^"")"
I $G(PSSPK)]"" D
.I SCR("S")]"" S SCR("S")=SCR("S")_" S PSSZ3=0 F PSSZ4=1:1:$L(PSSPK) Q:PSSZ3 I $P($G(^PSDRUG(+Y,2)),""^"",3)[$E(PSSPK,PSSZ4) S PSSZ3=1" Q
.S SCR("S")="S PSSZ3=0 F PSSZ4=1:1:$L(PSSPK) Q:PSSZ3 I $P($G(^PSDRUG(+Y,2)),""^"",3)[$E(PSSPK,PSSZ4) S PSSZ3=1"
;I $G(PSSPK)]"" S SCR("S")=$S(SCR("S")]"":SCR("S")_" I $G(^PSDRUG(+Y,2)),$P($G(^PSDRUG(+Y,2)),""^"",3)[PSSPK",1:"I $G(^PSDRUG(+Y,2)),$P($G(^PSDRUG(+Y,2)),""^"",3)[PSSPK")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSS50F1 9555 printed Oct 16, 2024@18:30:37 Page 2
PSS50F1 ;BIR/RTR - API FOR INFORMATION FROM FILE 50
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**85**;9/30/97
+2 ;
+3 ;Reference to ^PS(50.605 is supported by DBIA #2138
+4 ;
LIST ;
+1 ;PSSFT - Free Text name in 50
+2 ;PSSFL - Inactive flag - "" - All entries
+3 ; FileMan Date - Only entries with no Inactive Date or an Inactive Date greater than this date.
+4 ;PSSD - Index used in the lookup in the format B^C
+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,PSSP50,SCR,PSS,CNT,PSSXSUB,PSSLUPAR,PSSLUPP,PSSSCRN,PSSENCT
+11 IF $GET(LIST)']""
QUIT
+12 KILL ^TMP($JOB,LIST)
+13 IF $GET(PSSFT)']""
SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
QUIT
+14 SET SCR("S")=""
+15 SET PSSXSUB=""
DO SETXSUB
+16 SET PSSENCT=0
+17 IF +$GET(PSSFL)>0!($GET(PSSPK)]"")
NEW PSS5ND,PSSZ3,PSSZ4
DO SETSCRN^PSS50A
+18 IF $GET(PSSFT)]""
Begin DoDot:1
+19 IF PSSFT["??"
DO LOOP
QUIT
+20 KILL ^TMP("DILIST",$JOB),^TMP($JOB,"PSSLDONE")
+21 SET PSSSCRN=$GET(SCR("S"))
if $GET(PSSD)=""
SET PSSD="B"
DO PARSE^PSS50F(PSSD)
IF '$ORDER(PSSLUPAR(0))
QUIT
+22 SET PSSLUPP=0
FOR
SET PSSLUPP=$ORDER(PSSLUPAR(PSSLUPP))
if 'PSSLUPP
QUIT
Begin DoDot:2
+23 SET SCR("S")=$GET(PSSSCRN)
+24 DO FIND^DIC(50,,"@;.01","QPB"_$SELECT($PIECE(PSSLUPAR(PSSLUPP),"^",2):"X",1:""),PSSFT,,PSSLUPAR(PSSLUPP),SCR("S"),,"")
+25 IF +$GET(^TMP("DILIST",$JOB,0))=0
QUIT
+26 IF +^TMP("DILIST",$JOB,0)>0
NEW PSSXX
SET PSSXX=0
FOR
SET PSSXX=$ORDER(^TMP("DILIST",$JOB,PSSXX))
if 'PSSXX
QUIT
Begin DoDot:3
+27 SET PSSIEN=+^TMP("DILIST",$JOB,PSSXX,0)
IF '$DATA(^TMP($JOB,"PSSLDONE",PSSIEN))
SET ^TMP($JOB,"PSSLDONE",PSSIEN)=""
Begin DoDot:4
+28 KILL ^TMP("PSSP50",$JOB)
DO GETS^DIQ(50,+PSSIEN,".01;100;2.1","IE","^TMP(""PSSP50"",$J)")
SET PSS(1)=0
+29 FOR
SET PSS(1)=$ORDER(^TMP("PSSP50",$JOB,50,PSS(1)))
if 'PSS(1)
QUIT
DO SETLIST
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+30 SET ^TMP($JOB,LIST,0)=$SELECT($GET(PSSENCT):$GET(PSSENCT),1:"-1^NO DATA FOUND")
+31 KILL ^TMP("DILIST",$JOB),^TMP("PSSP50",$JOB),^TMP($JOB,"PSSLDONE")
+32 QUIT
SETLIST ;
+1 SET PSSENCT=PSSENCT+1
+2 SET ^TMP($JOB,LIST,+PSS(1),.01)=$GET(^TMP("PSSP50",$JOB,50,PSS(1),.01,"I"))
+3 ;S ^TMP($J,LIST,"B",$G(^TMP("PSSP50",$J,50,PSS(1),.01,"I")),+PSS(1))=""
+4 ;S ^TMP($J,LIST,$S($G(PSSD)]"":$P(PSSD,"^"),1:"B"),^TMP("PSSP50",$J,50,PSS(1),.01,"I"),+PSS(1))=""
+5 SET ^TMP($JOB,LIST,$SELECT($GET(PSSXSUB)'="":$GET(PSSXSUB),1:"B"),^TMP("PSSP50",$JOB,50,PSS(1),.01,"I"),+PSS(1))=""
+6 SET ^TMP($JOB,LIST,+PSS(1),2.1)=$SELECT($GET(^TMP("PSSP50",$JOB,50,PSS(1),2.1,"I"))="":"",1:$GET(^TMP("PSSP50",$JOB,50,PSS(1),2.1,"I"))_"^"_$GET(^TMP("PSSP50",$JOB,50,PSS(1),2.1,"E")))
+7 IF $PIECE($GET(^TMP($JOB,LIST,+PSS(1),2.1)),"^")
Begin DoDot:1
+8 NEW PSSADDF
SET PSSADDF=$$SETDF^PSS50AQM($PIECE(^TMP($JOB,LIST,+PSS(1),2.1),"^"))
SET ^TMP($JOB,LIST,+PSS(1),2.1)=^TMP($JOB,LIST,+PSS(1),2.1)_$SELECT($PIECE($GET(PSSADDF),"^")>0:"^"_$PIECE($GET(PSSADDF),"^",3)_"^"_$PIECE($GET(PSSADDF),"^",4),1:"")
End DoDot:1
+9 SET ^TMP($JOB,LIST,+PSS(1),100)=$SELECT($GET(^TMP("PSSP50",$JOB,50,PSS(1),100,"I"))="":"",1:$GET(^TMP("PSSP50",$JOB,50,PSS(1),100,"I"))_"^"_$GET(^TMP("PSSP50",$JOB,50,PSS(1),100,"E")))
+10 QUIT
LOOP ;
+1 SET PSS(1)=0
FOR
SET PSS(1)=$ORDER(^PSDRUG(PSS(1)))
if 'PSS(1)
QUIT
Begin DoDot:1
+2 IF $PIECE($GET(^PSDRUG(PSS(1),0)),"^")=""
QUIT
+3 IF $GET(PSSFL)
IF $PIECE($GET(^PSDRUG(PSS(1),"I")),"^")
IF $PIECE($GET(^("I")),"^")'>PSSFL
QUIT
+4 ;I $G(PSSRTOI)=1,'$P($G(^PSDRUG(PSS(1),2)),"^") Q
+5 ;Naked reference below refers to ^PSDRUG(PSS(1),2)
+6 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
+7 IF $GET(PSSPK)]""
IF 'PSSZ5
QUIT
+8 DO SETLISTL
+9 SET PSSENCT=PSSENCT+1
End DoDot:1
+10 QUIT
SETLISTL ;
+1 NEW PSSZNODE,PSS2NODE
SET PSSZNODE=$GET(^PSDRUG(PSS(1),0))
SET PSS2NODE=$GET(^(2))
+2 SET ^TMP($JOB,LIST,+PSS(1),.01)=$PIECE(PSSZNODE,"^")
+3 SET ^TMP($JOB,LIST,"B",$PIECE(PSSZNODE,"^"),+PSS(1))=""
+4 SET ^TMP($JOB,LIST,+PSS(1),2.1)=$SELECT('$PIECE(PSS2NODE,"^"):"",1:$PIECE(PSS2NODE,"^")_"^"_$PIECE($GET(^PS(50.7,+$PIECE(PSS2NODE,"^"),0)),"^"))
+5 NEW PSSADDF
SET PSSADDF=$PIECE($GET(^PS(50.7,+$PIECE($GET(^TMP($JOB,LIST,+PSS(1),2.1)),"^"),0)),"^",2)
IF PSSADDF>0
Begin DoDot:1
+6 SET ^TMP($JOB,LIST,+PSS(1),2.1)=^TMP($JOB,LIST,+PSS(1),2.1)_"^"_PSSADDF_"^"_$PIECE($GET(^PS(50.606,PSSADDF,0)),"^")
End DoDot:1
+7 NEW Y
SET Y=$PIECE($GET(^PSDRUG(PSS(1),"I")),"^")
Begin DoDot:1
+8 IF Y
SET ^TMP($JOB,LIST,+PSS(1),100)=$GET(Y)
XECUTE ^DD("DD")
SET ^TMP($JOB,LIST,+PSS(1),100)=^TMP($JOB,LIST,+PSS(1),100)_"^"_$GET(Y)
QUIT
+9 SET ^TMP($JOB,LIST,+PSS(1),100)=""
End DoDot:1
+10 QUIT
SETXSUB ;
+1 if $GET(PSSD)=""
QUIT
+2 NEW PSSLSX,PSSLSXCT,PSSLCNT,PSSDSUB
+3 SET PSSLSXCT=0
+4 FOR PSSLSX=1:1:$LENGTH(PSSD)
IF $EXTRACT(PSSD,PSSLSX)="^"
SET PSSLSXCT=PSSLSXCT+1
+5 SET PSSLSXCT=PSSLSXCT+1
+6 SET PSSLCNT=0
FOR PSSLSX=1:1:PSSLSXCT
SET PSSDSUB=$PIECE(PSSD,"^",PSSLSX)
if PSSLCNT>1
QUIT
SET PSSXSUB=$SELECT(PSSDSUB'="":PSSDSUB,PSSXSUB'="":PSSXSUB,1:"")
if PSSDSUB'=""
SET PSSLCNT=PSSLCNT+1
+7 IF PSSLCNT>1
SET PSSXSUB=""
+8 QUIT
LOOKUP ;
+1 ;PSSFT - Free Text value that could be the NAME field (#.01), IEN, VA PRODUCT NAME field (#21), NATIONAL DRUG CLASS field (#25),
+2 ; or SYNONYM (#.01) mutiple of the DRUG file (#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 - 1 - only drugs with data in the PHARMACY ORDERABLE ITEM field (#2.1) will be returned.
+9 ;PSSIFCAP - 1 - only drugs with no data in the IFCAP ITEM NUMBER multiple (#441) will be returned.
+10 ;PSSCMOP - 1 - only drugs with no data in the CMOP ID field (#27) will be returned.
+11 ;PSSD - Index used in the lookup in the format B^C.
+12 ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is the Field Number of the data
+13 ; piece being returned.
+14 NEW PSSLKIEN,PSSLKSUB,PSSENCT,SCR,PSSXSUB,CNT,PSS,DIERR
+15 IF $GET(LIST)']""
QUIT
+16 KILL ^TMP($JOB,LIST)
+17 IF $GET(PSSFT)']""
SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
QUIT
+18 SET PSSENCT=0
+19 IF PSSFT["??"
DO LOOPLK
QUIT
+20 SET SCR("S")=""
+21 IF $GET(PSSCMOP)=1
Begin DoDot:1
+22 SET SCR("S")="I $P($G(^(""ND"")),""^"",10)="""""
QUIT
End DoDot:1
+23 IF $GET(PSSIFCAP)=1
Begin DoDot:1
+24 IF SCR("S")=""
SET SCR("S")="I '$O(^PSDRUG(+Y,441,0))"
QUIT
+25 SET SCR("S")=SCR("S")_" I '$O(^PSDRUG(+Y,441,0))"
End DoDot:1
+26 IF +$GET(PSSFL)>0!($GET(PSSPK)]"")!($GET(PSSRTOI)=1)
NEW PSS5ND,PSSZ3,PSSZ4
DO SETSCRN
+27 IF PSSFT'=""
IF PSSFT?1"`"1N.N
Begin DoDot:1
+28 NEW PSSIEN2
SET PSSIEN2=$$FIND1^DIC(50,"","A",PSSFT,,SCR("S"),"")
+29 KILL ^TMP("DIERR",$JOB)
+30 IF +PSSIEN2'>0
QUIT
+31 IF $PIECE($GET(^PSDRUG(+PSSIEN2,0)),"^")=""
QUIT
+32 SET PSSLKIEN=+PSSIEN2
SET PSSLKSUB="B"
+33 DO LOOKSET
End DoDot:1
SET ^TMP($JOB,LIST,0)=$SELECT($GET(PSSENCT):$GET(PSSENCT),1:"-1^NO DATA FOUND")
QUIT
+34 IF $GET(PSSFT)]""
Begin DoDot:1
+35 NEW PSSLUPAR,PSSLUPP,PSSSCRN
+36 SET PSSXSUB=""
DO SETXSUB
SET PSSLKSUB=$SELECT($GET(PSSXSUB)'="":$GET(PSSXSUB),1:"B")
+37 KILL ^TMP("DILIST",$JOB),^TMP($JOB,"PSSLDONE")
+38 SET PSSSCRN=$GET(SCR("S"))
if $GET(PSSD)=""
SET PSSD="B"
DO PARSE^PSS50F(PSSD)
IF '$ORDER(PSSLUPAR(0))
QUIT
+39 SET PSSLUPP=0
FOR
SET PSSLUPP=$ORDER(PSSLUPAR(PSSLUPP))
if 'PSSLUPP
QUIT
Begin DoDot:2
+40 SET SCR("S")=PSSSCRN
+41 DO FIND^DIC(50,,"@;.01","QPB"_$SELECT($PIECE(PSSLUPAR(PSSLUPP),"^",2):"X",1:""),PSSFT,,PSSLUPAR(PSSLUPP),SCR("S"),,"")
+42 IF +$GET(^TMP("DILIST",$JOB,0))=0
QUIT
+43 IF +^TMP("DILIST",$JOB,0)>0
NEW PSSXX
SET PSSXX=0
FOR
SET PSSXX=$ORDER(^TMP("DILIST",$JOB,PSSXX))
if 'PSSXX
QUIT
Begin DoDot:3
+44 SET PSSLKIEN=+^TMP("DILIST",$JOB,PSSXX,0)
IF $PIECE($GET(^PSDRUG(PSSLKIEN,0)),"^")'=""
IF '$DATA(^TMP($JOB,"PSSLDONE",PSSLKIEN))
SET ^TMP($JOB,"PSSLDONE",PSSLKIEN)=""
DO LOOKSET
End DoDot:3
End DoDot:2
End DoDot:1
+45 SET ^TMP($JOB,LIST,0)=$SELECT($GET(PSSENCT):$GET(PSSENCT),1:"-1^NO DATA FOUND")
+46 KILL ^TMP("DILIST",$JOB),^TMP($JOB,"PSSLDONE")
+47 QUIT
LOOKSET ;
+1 ;PSSLKIEN = ien from File 50
+2 ;PSSLKSUB = Subscript for the cross reference return
+3 NEW PSSLKNAM,PSSLKND,PSSLKZER
+4 SET PSSLKNAM=$PIECE($GET(^PSDRUG(PSSLKIEN,0)),"^")
SET PSSLKND=$GET(^("ND"))
SET PSSLKZER=$GET(^(0))
if PSSLKNAM=""
QUIT
+5 SET ^TMP($JOB,LIST,PSSLKIEN,.01)=PSSLKNAM
+6 SET ^TMP($JOB,LIST,PSSLKSUB,PSSLKNAM,PSSLKIEN)=""
+7 SET PSSENCT=PSSENCT+1
+8 SET ^TMP($JOB,LIST,PSSLKIEN,25)=$SELECT($PIECE(PSSLKND,"^",6):$PIECE(PSSLKND,"^",6)_"^"_$PIECE($GET(^PS(50.605,+$PIECE(PSSLKND,"^",6),0)),"^")_"^"_$PIECE($GET(^(0)),"^",2),1:"")
+9 NEW Y
SET Y=$PIECE($GET(^PSDRUG(PSSLKIEN,"I")),"^")
Begin DoDot:1
+10 IF Y
SET ^TMP($JOB,LIST,PSSLKIEN,100)=$GET(Y)
XECUTE ^DD("DD")
SET ^TMP($JOB,LIST,PSSLKIEN,100)=^TMP($JOB,LIST,PSSLKIEN,100)_"^"_$GET(Y)
QUIT
+11 SET ^TMP($JOB,LIST,PSSLKIEN,100)=""
End DoDot:1
+12 SET ^TMP($JOB,LIST,PSSLKIEN,101)=$PIECE(PSSLKZER,"^",10)
+13 QUIT
LOOPLK ;
+1 SET PSSLKSUB="B"
+2 SET PSSLKIEN=0
FOR
SET PSSLKIEN=$ORDER(^PSDRUG(PSSLKIEN))
if 'PSSLKIEN
QUIT
Begin DoDot:1
+3 IF $PIECE($GET(^PSDRUG(PSSLKIEN,0)),"^")=""
QUIT
+4 IF $GET(PSSCMOP)=1
IF $PIECE($GET(^PSDRUG(PSSLKIEN,"ND")),"^",10)'=""
QUIT
+5 IF $GET(PSSIFCAP)=1
IF $ORDER(^PSDRUG(PSSLKIEN,441,0))
QUIT
+6 IF $GET(PSSFL)
IF $PIECE($GET(^PSDRUG(PSSLKIEN,"I")),"^")
IF $PIECE($GET(^("I")),"^")'>PSSFL
QUIT
+7 IF $GET(PSSRTOI)=1
IF '$PIECE($GET(^PSDRUG(PSSLKIEN,2)),"^")
QUIT
+8 IF $GET(PSSPK)]""
NEW PSSZ5,PSSZ6
SET PSSZ5=0
FOR PSSZ6=1:1:$LENGTH(PSSPK)
if PSSZ5
QUIT
IF $PIECE($GET(^PSDRUG(PSSLKIEN,2)),"^",3)[$EXTRACT(PSSPK,PSSZ6)
SET PSSZ5=1
+9 IF $GET(PSSPK)]""
IF 'PSSZ5
QUIT
+10 DO LOOKSET
End DoDot:1
+11 SET ^TMP($JOB,LIST,0)=$SELECT($GET(PSSENCT):$GET(PSSENCT),1:"-1^NO DATA FOUND")
+12 QUIT
+13 ;
SETSCRN ;Set Screen
+1 IF +$GET(PSSFL)>0
Begin DoDot:1
+2 IF SCR("S")]""
SET SCR("S")=SCR("S")_" S PSS5ND=$P($G(^PSDRUG(+Y,""I"")),""^"") I PSS5ND=""""!(PSS5ND>PSSFL)"
QUIT
+3 SET SCR("S")="S PSS5ND=$P($G(^PSDRUG(+Y,""I"")),""^"") I PSS5ND=""""!(PSS5ND>PSSFL)"
End DoDot:1
+4 IF $GET(PSSRTOI)=1
Begin DoDot:1
+5 IF SCR("S")]""
SET SCR("S")=SCR("S")_" I $P($G(^PSDRUG(+Y,2)),""^"")"
QUIT
+6 SET SCR("S")="I $P($G(^PSDRUG(+Y,2)),""^"")"
End DoDot:1
+7 IF $GET(PSSPK)]""
Begin DoDot:1
+8 IF SCR("S")]""
SET SCR("S")=SCR("S")_" S PSSZ3=0 F PSSZ4=1:1:$L(PSSPK) Q:PSSZ3 I $P($G(^PSDRUG(+Y,2)),""^"",3)[$E(PSSPK,PSSZ4) S PSSZ3=1"
QUIT
+9 SET SCR("S")="S PSSZ3=0 F PSSZ4=1:1:$L(PSSPK) Q:PSSZ3 I $P($G(^PSDRUG(+Y,2)),""^"",3)[$E(PSSPK,PSSZ4) S PSSZ3=1"
End DoDot:1
+10 ;I $G(PSSPK)]"" S SCR("S")=$S(SCR("S")]"":SCR("S")_" I $G(^PSDRUG(+Y,2)),$P($G(^PSDRUG(+Y,2)),""^"",3)[PSSPK",1:"I $G(^PSDRUG(+Y,2)),$P($G(^PSDRUG(+Y,2)),""^"",3)[PSSPK")
+11 QUIT
