PSS50B1 ;BIR/LDT - API FOR INFORMATION FROM FILE 50; 5 Sep 03
;;1.0;PHARMACY DATA MANAGEMENT;**85**;9/30/97
;
LOOP ;
N PSS50DD5,PSS50ER5,PSS501NX D FIELD^DID(50.1,1,"Z","POINTER","PSS50DD5","PSS50ER5") S PSS501NX=$G(PSS50DD5("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)),SETSUB4^PSS50AQM(PSS(1))
.D SETINV,SETSYN2,SETIFC
.S PSSENCT=PSSENCT+1
S ^TMP($J,LIST,0)=$S($G(PSSENCT):$G(PSSENCT),1:"-1^NO DATA FOUND")
Q
SETINV ;
N PSSZNODE,PSS660,PSS6601
S PSSZNODE=$G(^PSDRUG(PSS(1),0)),PSS660=$G(^(660)),PSS6601=$G(^(660.1))
S ^TMP($J,LIST,+PSS(1),.01)=$P(PSSZNODE,"^")
S ^TMP($J,LIST,"B",$P(PSSZNODE,"^"),+PSS(1))=""
S ^TMP($J,LIST,+PSS(1),11)=$P(PSS660,"^")
S ^TMP($J,LIST,+PSS(1),12)=$S($P(PSS660,"^",2):$P(PSS660,"^",2)_"^"_$P($G(^DIC(51.5,+$P(PSS660,"^",2),0)),"^")_"^"_$P($G(^(0)),"^",2),1:"")
S ^TMP($J,LIST,+PSS(1),13)=$P(PSS660,"^",3)
S ^TMP($J,LIST,+PSS(1),14)=$P(PSS660,"^",4)
S ^TMP($J,LIST,+PSS(1),15)=$P(PSS660,"^",5)
S ^TMP($J,LIST,+PSS(1),16)=$P(PSS660,"^",6)
S ^TMP($J,LIST,+PSS(1),17)=$P(PSS660,"^",7)
S ^TMP($J,LIST,+PSS(1),14.5)=$P(PSS660,"^",8)
N Y S Y=$P(PSS660,"^",9) D
.I Y S ^TMP($J,LIST,+PSS(1),17.1)=$G(Y) X ^DD("DD") S ^TMP($J,LIST,+PSS(1),17.1)=^TMP($J,LIST,+PSS(1),17.1)_"^"_$G(Y) Q
.S ^TMP($J,LIST,+PSS(1),17.1)=""
S ^TMP($J,LIST,+PSS(1),50)=$P(PSS6601,"^")
Q
SETSYN2 ;
N PSS501C S PSS501C=0
I $O(^PSDRUG(PSS(1),1,0)) N PSS501,PSS501ND D
.F PSS501=0:0 S PSS501=$O(^PSDRUG(PSS(1),1,PSS501)) Q:'PSS501 D
..S PSS501ND=$G(^PSDRUG(PSS(1),1,PSS501,0)) I $P(PSS501ND,"^")'="" S PSS501C=PSS501C+1 D
...S ^TMP($J,LIST,+PSS(1),"SYN",PSS501,.01)=$P(PSS501ND,"^")
...N PSS501NN S PSS501NN=$P(PSS501ND,"^",3) D
....I PSS501NN'="",PSS501NX'="",PSS501NX[(PSS501NN_":") S ^TMP($J,LIST,+PSS(1),"SYN",PSS501,1)=PSS501NN_"^"_$P($E(PSS501NX,$F(PSS501NX,(PSS501NN_":")),999),";") Q
....S ^TMP($J,LIST,+PSS(1),"SYN",PSS501,1)=""
...S ^TMP($J,LIST,+PSS(1),"SYN",PSS501,2)=$P(PSS501ND,"^",2)
...S ^TMP($J,LIST,+PSS(1),"SYN",PSS501,400)=$P(PSS501ND,"^",4)
...S ^TMP($J,LIST,+PSS(1),"SYN",PSS501,401)=$S($P(PSS501ND,"^",5):$P(PSS501ND,"^",5)_"^"_$P($G(^DIC(51.5,+$P(PSS501ND,"^",5),0)),"^")_"^"_$P($G(^(0)),"^",2),1:"")
...S ^TMP($J,LIST,+PSS(1),"SYN",PSS501,402)=$P(PSS501ND,"^",6)
...S ^TMP($J,LIST,+PSS(1),"SYN",PSS501,403)=$P(PSS501ND,"^",7)
...S ^TMP($J,LIST,+PSS(1),"SYN",PSS501,404)=$P(PSS501ND,"^",8)
...S ^TMP($J,LIST,+PSS(1),"SYN",PSS501,405)=$P(PSS501ND,"^",9)
S ^TMP($J,LIST,+PSS(1),"SYN",0)=$S(PSS501C:PSS501C,1:"-1^NO DATA FOUND")
Q
SETIFC ;
N PSS441C S PSS441C=0
I $O(^PSDRUG(PSS(1),441,0)) N PSS441,PSS441ND D
.F PSS441=0:0 S PSS441=$O(^PSDRUG(PSS(1),441,PSS441)) Q:'PSS441 D
..S PSS441ND=$G(^PSDRUG(PSS(1),441,PSS441,0)) I $P(PSS441ND,"^")'="" S PSS441C=PSS441C+1 D
...S ^TMP($J,LIST,+PSS(1),"IFC",PSS441,.01)=$P(PSS441ND,"^")
S ^TMP($J,LIST,+PSS(1),"IFC",0)=$S(PSS441C:PSS441C,1:"-1^NO DATA FOUND")
Q
;
AVSN ;
;PSSVAL - ITEM NUMBER sub-field (#.01) of the IFCAP ITEM NUMBER multiple 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.
;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.
;Returns zero node of 50
I $G(LIST)']"" Q
K ^TMP($J,LIST)
I +$G(PSSVAL)'>0 S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
N PSS,CNT,PSSIEN S (CNT,PSS)=0 F S PSS=$O(^PSDRUG("AVSN",+PSSVAL,PSS)) Q:'PSS D
.N INODE,NODE2 S NODE2=$G(^PSDRUG(+PSS,2)),INODE=$G(^("I"))
.I +$G(PSSFL)>0,+INODE>0,+INODE'>PSSFL Q
.;Naked reference below refers to ^PSDRUG(+Y,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($J,"PSS50") D GETS^DIQ(50,+PSS,".01;9*","IE","^TMP($J,""PSS50""") D
..S PSS(1)=0 F S PSS(1)=$O(^TMP($J,"PSS50",50,PSS(1))) Q:'PSS(1) D
...S ^TMP($J,LIST,+PSS(1),.01)=$G(^TMP($J,"PSS50",50,PSS(1),.01,"I")),CNT=CNT+1
...S ^TMP($J,LIST,"AVSN",$G(^TMP($J,"PSS50",50,PSS(1),.01,"I")),+PSS(1))="",PSSIEN=+PSS(1)
..S (CNT(1),PSS(2))=0 F S PSS(2)=$O(^TMP($J,"PSS50",50.1,PSS(2))) Q:'PSS(2) D
...S ^TMP($J,LIST,+PSSIEN,"SYN",+PSS(2),.01)=$G(^TMP($J,"PSS50",50.1,PSS(2),.01,"I")),CNT(1)=CNT(1)+1
...S ^TMP($J,LIST,+PSSIEN,"SYN",+PSS(2),2)=$G(^TMP($J,"PSS50",50.1,PSS(2),2,"I"))
...S ^TMP($J,LIST,+PSSIEN,"SYN",+PSS(2),1)=$S($G(^TMP($J,"PSS50",50.1,PSS(2),1,"I"))="":"",1:$G(^TMP($J,"PSS50",50.1,PSS(2),1,"I"))_"^"_$G(^TMP($J,"PSS50",50.1,PSS(2),1,"E")))
...S ^TMP($J,LIST,+PSSIEN,"SYN",+PSS(2),400)=$G(^TMP($J,"PSS50",50.1,PSS(2),400,"I"))
...S ^TMP($J,LIST,+PSSIEN,"SYN",+PSS(2),401)=$S($G(^TMP($J,"PSS50",50.1,PSS(2),401,"I"))="":"",1:$G(^TMP($J,"PSS50",50.1,PSS(2),401,"I"))_"^"_$G(^TMP($J,"PSS50",50.1,PSS(2),401,"E")))
...S ^TMP($J,LIST,+PSSIEN,"SYN",+PSS(2),402)=$G(^TMP($J,"PSS50",50.1,PSS(2),402,"I"))
...S ^TMP($J,LIST,+PSSIEN,"SYN",+PSS(2),403)=$G(^TMP($J,"PSS50",50.1,PSS(2),403,"I"))
...S ^TMP($J,LIST,+PSSIEN,"SYN",+PSS(2),404)=$G(^TMP($J,"PSS50",50.1,PSS(2),404,"I"))
...S ^TMP($J,LIST,+PSSIEN,"SYN",+PSS(2),405)=$G(^TMP($J,"PSS50",50.1,PSS(2),405,"I"))
..S ^TMP($J,LIST,+PSSIEN,"SYN",0)=$S(CNT(1)>0:CNT(1),1:"-1^NO DATA FOUND")
S ^TMP($J,LIST,0)=$S(CNT>0:CNT,1:"-1^NO DATA FOUND")
K ^TMP($J,"PSS50")
Q
;
AQ1 ;
;PSSVAL - ITEM NUMBER sub-field (#.01) of the IFCAP ITEM NUMBER multiple 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.
;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.
;Returns zero node of 50
I $G(LIST)']"" Q
K ^TMP($J,LIST)
I $G(PSSVAL)']"" S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
N PSS,CNT S (CNT,PSS)=0 F S PSS=$O(^PSDRUG("AQ1",PSSVAL,PSS)) Q:'PSS D
.N INODE,NODE2,ZNODE S NODE2=$G(^PSDRUG(+PSS,2)),INODE=$G(^("I")),ZNODE=$G(^(0))
.I +$G(PSSFL)>0,+INODE>0,+INODE'>PSSFL Q
.;Naked reference below refers to ^PSDRUG(+PSS,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
.S ^TMP($J,LIST,+PSS,.01)=$P(ZNODE,"^"),CNT=CNT+1
.S ^TMP($J,LIST,"AQ1",$P(ZNODE,"^"),+PSS)=""
S ^TMP($J,LIST,0)=$S(CNT>0:CNT,1:"-1^NO DATA FOUND")
Q
;
AIU ;
;PSSFT - NAME field (#.01) of the DRUG file (#50)
;PSSPK - Application Package's Use - "" - All entries
; Alphabetic codes that represent the DHCP packages that consider this drug to be
; part of their formulary.
;PSSFL - Inactive flag - "" - All entries
; FileMan Date - Only entries with no Inactive Date or an Inactive Date greater than this date.
;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.
;Returns NAME field (#.01) of DRUG file (#50).
I $G(LIST)']"" Q
K ^TMP($J,LIST)
I $G(PSSFT)']"" S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
I $G(PSSPK)']"" S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
N PSS,CNT S CNT=0,PSS="" F S PSS=$O(^PSDRUG("AIU"_PSSPK,PSS)) Q:PSS="" S PSS(1)=0 F S PSS(1)=$O(^PSDRUG("AIU"_PSSPK,PSS,PSS(1))) Q:'PSS(1) D
.N INODE,NODE2,ZNODE S NODE2=$G(^PSDRUG(+PSS(1),2)),INODE=$G(^("I")),ZNODE=$G(^(0))
.I +$G(PSSFL)>0,+INODE>0,+INODE'>PSSFL Q
.I $E(PSS,1,$L(PSSFT))'[PSSFT Q
.S ^TMP($J,LIST,+PSS(1),.01)=$P(ZNODE,"^"),CNT=CNT+1
.S ^TMP($J,LIST,"AIU",$P(ZNODE,"^"),+PSS(1))=""
S ^TMP($J,LIST,0)=$S(CNT>0:CNT,1:"-1^NO DATA FOUND")
Q
;
IU ;
;PSSFL - Inactive flag - "" - All entries
; FileMan Date - Only entries with no Inactive Date or an Inactive Date greater than this date.
;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.
;Returns NAME field (#.01) of DRUG file (#50).
I $G(LIST)']"" Q
K ^TMP($J,LIST)
N PSS,CNT
S CNT=0,PSS="" F S PSS=$O(^PSDRUG("IU",PSS)) Q:PSS="" I PSS'["O"&(PSS'["U")&(PSS'["I")&(PSS'["N") S PSS(1)=0 F S PSS(1)=$O(^PSDRUG("IU",PSS,PSS(1))) Q:'PSS(1) D
.N INODE,ZNODE S ZNODE=$G(^PSDRUG(+PSS(1),0)),INODE=$G(^("I"))
.I +$G(PSSFL)>0,+INODE>0,+INODE'>PSSFL Q
.S ^TMP($J,LIST,+PSS(1),.01)=$P(ZNODE,"^"),CNT=CNT+1
.S ^TMP($J,LIST,"IU",$P(ZNODE,"^"),+PSS(1))=""
S ^TMP($J,LIST,0)=$S(CNT>0:CNT,1:"-1^NO DATA FOUND")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSS50B1 9660 printed Nov 22, 2024@17:39:46 Page 2
PSS50B1 ;BIR/LDT - API FOR INFORMATION FROM FILE 50; 5 Sep 03
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**85**;9/30/97
+2 ;
LOOP ;
+1 NEW PSS50DD5,PSS50ER5,PSS501NX
DO FIELD^DID(50.1,1,"Z","POINTER","PSS50DD5","PSS50ER5")
SET PSS501NX=$GET(PSS50DD5("POINTER"))
+2 NEW PSSENCT
+3 SET PSSENCT=0
+4 SET PSS(1)=0
FOR
SET PSS(1)=$ORDER(^PSDRUG(PSS(1)))
if 'PSS(1)
QUIT
Begin DoDot:1
+5 IF $PIECE($GET(^PSDRUG(PSS(1),0)),"^")=""
QUIT
+6 IF $GET(PSSFL)
IF $PIECE($GET(^PSDRUG(PSS(1),"I")),"^")
IF $PIECE($GET(^("I")),"^")'>PSSFL
QUIT
+7 IF $GET(PSSRTOI)=1
IF '$PIECE($GET(^PSDRUG(PSS(1),2)),"^")
QUIT
+8 ;Naked reference below refers to ^PSDRUG(PSS(1),2)
+9 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
+10 IF $GET(PSSPK)]""
IF 'PSSZ5
QUIT
+11 DO SETSUB1^PSS50AQM(PSS(1))
DO SETSUB4^PSS50AQM(PSS(1))
+12 DO SETINV
DO SETSYN2
DO SETIFC
+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 QUIT
SETINV ;
+1 NEW PSSZNODE,PSS660,PSS6601
+2 SET PSSZNODE=$GET(^PSDRUG(PSS(1),0))
SET PSS660=$GET(^(660))
SET PSS6601=$GET(^(660.1))
+3 SET ^TMP($JOB,LIST,+PSS(1),.01)=$PIECE(PSSZNODE,"^")
+4 SET ^TMP($JOB,LIST,"B",$PIECE(PSSZNODE,"^"),+PSS(1))=""
+5 SET ^TMP($JOB,LIST,+PSS(1),11)=$PIECE(PSS660,"^")
+6 SET ^TMP($JOB,LIST,+PSS(1),12)=$SELECT($PIECE(PSS660,"^",2):$PIECE(PSS660,"^",2)_"^"_$PIECE($GET(^DIC(51.5,+$PIECE(PSS660,"^",2),0)),"^")_"^"_$PIECE($GET(^(0)),"^",2),1:"")
+7 SET ^TMP($JOB,LIST,+PSS(1),13)=$PIECE(PSS660,"^",3)
+8 SET ^TMP($JOB,LIST,+PSS(1),14)=$PIECE(PSS660,"^",4)
+9 SET ^TMP($JOB,LIST,+PSS(1),15)=$PIECE(PSS660,"^",5)
+10 SET ^TMP($JOB,LIST,+PSS(1),16)=$PIECE(PSS660,"^",6)
+11 SET ^TMP($JOB,LIST,+PSS(1),17)=$PIECE(PSS660,"^",7)
+12 SET ^TMP($JOB,LIST,+PSS(1),14.5)=$PIECE(PSS660,"^",8)
+13 NEW Y
SET Y=$PIECE(PSS660,"^",9)
Begin DoDot:1
+14 IF Y
SET ^TMP($JOB,LIST,+PSS(1),17.1)=$GET(Y)
XECUTE ^DD("DD")
SET ^TMP($JOB,LIST,+PSS(1),17.1)=^TMP($JOB,LIST,+PSS(1),17.1)_"^"_$GET(Y)
QUIT
+15 SET ^TMP($JOB,LIST,+PSS(1),17.1)=""
End DoDot:1
+16 SET ^TMP($JOB,LIST,+PSS(1),50)=$PIECE(PSS6601,"^")
+17 QUIT
SETSYN2 ;
+1 NEW PSS501C
SET PSS501C=0
+2 IF $ORDER(^PSDRUG(PSS(1),1,0))
NEW PSS501,PSS501ND
Begin DoDot:1
+3 FOR PSS501=0:0
SET PSS501=$ORDER(^PSDRUG(PSS(1),1,PSS501))
if 'PSS501
QUIT
Begin DoDot:2
+4 SET PSS501ND=$GET(^PSDRUG(PSS(1),1,PSS501,0))
IF $PIECE(PSS501ND,"^")'=""
SET PSS501C=PSS501C+1
Begin DoDot:3
+5 SET ^TMP($JOB,LIST,+PSS(1),"SYN",PSS501,.01)=$PIECE(PSS501ND,"^")
+6 NEW PSS501NN
SET PSS501NN=$PIECE(PSS501ND,"^",3)
Begin DoDot:4
+7 IF PSS501NN'=""
IF PSS501NX'=""
IF PSS501NX[(PSS501NN_":")
SET ^TMP($JOB,LIST,+PSS(1),"SYN",PSS501,1)=PSS501NN_"^"_$PIECE($EXTRACT(PSS501NX,$FIND(PSS501NX,(PSS501NN_":")),999),";")
QUIT
+8 SET ^TMP($JOB,LIST,+PSS(1),"SYN",PSS501,1)=""
End DoDot:4
+9 SET ^TMP($JOB,LIST,+PSS(1),"SYN",PSS501,2)=$PIECE(PSS501ND,"^",2)
+10 SET ^TMP($JOB,LIST,+PSS(1),"SYN",PSS501,400)=$PIECE(PSS501ND,"^",4)
+11 SET ^TMP($JOB,LIST,+PSS(1),"SYN",PSS501,401)=$SELECT($PIECE(PSS501ND,"^",5):$PIECE(PSS501ND,"^",5)_"^"_$PIECE($GET(^DIC(51.5,+$PIECE(PSS501ND,"^",5),0)),"^")_"^"_$PIECE($GET(^(0)),"^",2),1:"")
+12 SET ^TMP($JOB,LIST,+PSS(1),"SYN",PSS501,402)=$PIECE(PSS501ND,"^",6)
+13 SET ^TMP($JOB,LIST,+PSS(1),"SYN",PSS501,403)=$PIECE(PSS501ND,"^",7)
+14 SET ^TMP($JOB,LIST,+PSS(1),"SYN",PSS501,404)=$PIECE(PSS501ND,"^",8)
+15 SET ^TMP($JOB,LIST,+PSS(1),"SYN",PSS501,405)=$PIECE(PSS501ND,"^",9)
End DoDot:3
End DoDot:2
End DoDot:1
+16 SET ^TMP($JOB,LIST,+PSS(1),"SYN",0)=$SELECT(PSS501C:PSS501C,1:"-1^NO DATA FOUND")
+17 QUIT
SETIFC ;
+1 NEW PSS441C
SET PSS441C=0
+2 IF $ORDER(^PSDRUG(PSS(1),441,0))
NEW PSS441,PSS441ND
Begin DoDot:1
+3 FOR PSS441=0:0
SET PSS441=$ORDER(^PSDRUG(PSS(1),441,PSS441))
if 'PSS441
QUIT
Begin DoDot:2
+4 SET PSS441ND=$GET(^PSDRUG(PSS(1),441,PSS441,0))
IF $PIECE(PSS441ND,"^")'=""
SET PSS441C=PSS441C+1
Begin DoDot:3
+5 SET ^TMP($JOB,LIST,+PSS(1),"IFC",PSS441,.01)=$PIECE(PSS441ND,"^")
End DoDot:3
End DoDot:2
End DoDot:1
+6 SET ^TMP($JOB,LIST,+PSS(1),"IFC",0)=$SELECT(PSS441C:PSS441C,1:"-1^NO DATA FOUND")
+7 QUIT
+8 ;
AVSN ;
+1 ;PSSVAL - ITEM NUMBER sub-field (#.01) of the IFCAP ITEM NUMBER multiple of the DRUG file (#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 ;PSSPK - Application Package's Use - "" - All entries
+5 ; Alphabetic codes that represent the DHCP packages that consider this drug to be
+6 ; part of their formulary.
+7 ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is the Field Number of the data
+8 ; piece being returned.
+9 ;Returns zero node of 50
+10 IF $GET(LIST)']""
QUIT
+11 KILL ^TMP($JOB,LIST)
+12 IF +$GET(PSSVAL)'>0
SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
QUIT
+13 NEW PSS,CNT,PSSIEN
SET (CNT,PSS)=0
FOR
SET PSS=$ORDER(^PSDRUG("AVSN",+PSSVAL,PSS))
if 'PSS
QUIT
Begin DoDot:1
+14 NEW INODE,NODE2
SET NODE2=$GET(^PSDRUG(+PSS,2))
SET INODE=$GET(^("I"))
+15 IF +$GET(PSSFL)>0
IF +INODE>0
IF +INODE'>PSSFL
QUIT
+16 ;Naked reference below refers to ^PSDRUG(+Y,2)
+17 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
+18 IF $GET(PSSPK)]""
IF 'PSSZ5
QUIT
+19 KILL ^TMP($JOB,"PSS50")
DO GETS^DIQ(50,+PSS,".01;9*","IE","^TMP($J,""PSS50""")
Begin DoDot:2
+20 SET PSS(1)=0
FOR
SET PSS(1)=$ORDER(^TMP($JOB,"PSS50",50,PSS(1)))
if 'PSS(1)
QUIT
Begin DoDot:3
+21 SET ^TMP($JOB,LIST,+PSS(1),.01)=$GET(^TMP($JOB,"PSS50",50,PSS(1),.01,"I"))
SET CNT=CNT+1
+22 SET ^TMP($JOB,LIST,"AVSN",$GET(^TMP($JOB,"PSS50",50,PSS(1),.01,"I")),+PSS(1))=""
SET PSSIEN=+PSS(1)
End DoDot:3
+23 SET (CNT(1),PSS(2))=0
FOR
SET PSS(2)=$ORDER(^TMP($JOB,"PSS50",50.1,PSS(2)))
if 'PSS(2)
QUIT
Begin DoDot:3
+24 SET ^TMP($JOB,LIST,+PSSIEN,"SYN",+PSS(2),.01)=$GET(^TMP($JOB,"PSS50",50.1,PSS(2),.01,"I"))
SET CNT(1)=CNT(1)+1
+25 SET ^TMP($JOB,LIST,+PSSIEN,"SYN",+PSS(2),2)=$GET(^TMP($JOB,"PSS50",50.1,PSS(2),2,"I"))
+26 SET ^TMP($JOB,LIST,+PSSIEN,"SYN",+PSS(2),1)=$SELECT($GET(^TMP($JOB,"PSS50",50.1,PSS(2),1,"I"))="":"",1:$GET(^TMP($JOB,"PSS50",50.1,PSS(2),1,"I"))_"^"_$GET(^TMP($JOB,"PSS50",50.1,PSS(2),1,"E")))
+27 SET ^TMP($JOB,LIST,+PSSIEN,"SYN",+PSS(2),400)=$GET(^TMP($JOB,"PSS50",50.1,PSS(2),400,"I"))
+28 SET ^TMP($JOB,LIST,+PSSIEN,"SYN",+PSS(2),401)=$SELECT($GET(^TMP($JOB,"PSS50",50.1,PSS(2),401,"I"))="":"",1:$GET(^TMP($JOB,"PSS50",50.1,PSS(2),401,"I"))_"^"_$GET(^TMP($JOB,"PSS50",50.1,PSS(2),401,"E")))
+29 SET ^TMP($JOB,LIST,+PSSIEN,"SYN",+PSS(2),402)=$GET(^TMP($JOB,"PSS50",50.1,PSS(2),402,"I"))
+30 SET ^TMP($JOB,LIST,+PSSIEN,"SYN",+PSS(2),403)=$GET(^TMP($JOB,"PSS50",50.1,PSS(2),403,"I"))
+31 SET ^TMP($JOB,LIST,+PSSIEN,"SYN",+PSS(2),404)=$GET(^TMP($JOB,"PSS50",50.1,PSS(2),404,"I"))
+32 SET ^TMP($JOB,LIST,+PSSIEN,"SYN",+PSS(2),405)=$GET(^TMP($JOB,"PSS50",50.1,PSS(2),405,"I"))
End DoDot:3
+33 SET ^TMP($JOB,LIST,+PSSIEN,"SYN",0)=$SELECT(CNT(1)>0:CNT(1),1:"-1^NO DATA FOUND")
End DoDot:2
End DoDot:1
+34 SET ^TMP($JOB,LIST,0)=$SELECT(CNT>0:CNT,1:"-1^NO DATA FOUND")
+35 KILL ^TMP($JOB,"PSS50")
+36 QUIT
+37 ;
AQ1 ;
+1 ;PSSVAL - ITEM NUMBER sub-field (#.01) of the IFCAP ITEM NUMBER multiple of the DRUG file (#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 ;PSSPK - Application Package's Use - "" - All entries
+5 ; Alphabetic codes that represent the DHCP packages that consider this drug to be
+6 ; part of their formulary.
+7 ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is the Field Number of the data
+8 ; piece being returned.
+9 ;Returns zero node of 50
+10 IF $GET(LIST)']""
QUIT
+11 KILL ^TMP($JOB,LIST)
+12 IF $GET(PSSVAL)']""
SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
QUIT
+13 NEW PSS,CNT
SET (CNT,PSS)=0
FOR
SET PSS=$ORDER(^PSDRUG("AQ1",PSSVAL,PSS))
if 'PSS
QUIT
Begin DoDot:1
+14 NEW INODE,NODE2,ZNODE
SET NODE2=$GET(^PSDRUG(+PSS,2))
SET INODE=$GET(^("I"))
SET ZNODE=$GET(^(0))
+15 IF +$GET(PSSFL)>0
IF +INODE>0
IF +INODE'>PSSFL
QUIT
+16 ;Naked reference below refers to ^PSDRUG(+PSS,2)
+17 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
+18 IF $GET(PSSPK)]""
IF 'PSSZ5
QUIT
+19 SET ^TMP($JOB,LIST,+PSS,.01)=$PIECE(ZNODE,"^")
SET CNT=CNT+1
+20 SET ^TMP($JOB,LIST,"AQ1",$PIECE(ZNODE,"^"),+PSS)=""
End DoDot:1
+21 SET ^TMP($JOB,LIST,0)=$SELECT(CNT>0:CNT,1:"-1^NO DATA FOUND")
+22 QUIT
+23 ;
AIU ;
+1 ;PSSFT - NAME field (#.01) of the DRUG file (#50)
+2 ;PSSPK - Application Package's Use - "" - All entries
+3 ; Alphabetic codes that represent the DHCP packages that consider this drug to be
+4 ; part of their formulary.
+5 ;PSSFL - Inactive flag - "" - All entries
+6 ; FileMan Date - Only entries with no Inactive Date or an Inactive Date greater than this date.
+7 ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is the Field Number of the data
+8 ; piece being returned.
+9 ;Returns NAME field (#.01) of DRUG file (#50).
+10 IF $GET(LIST)']""
QUIT
+11 KILL ^TMP($JOB,LIST)
+12 IF $GET(PSSFT)']""
SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
QUIT
+13 IF $GET(PSSPK)']""
SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
QUIT
+14 NEW PSS,CNT
SET CNT=0
SET PSS=""
FOR
SET PSS=$ORDER(^PSDRUG("AIU"_PSSPK,PSS))
if PSS=""
QUIT
SET PSS(1)=0
FOR
SET PSS(1)=$ORDER(^PSDRUG("AIU"_PSSPK,PSS,PSS(1)))
if 'PSS(1)
QUIT
Begin DoDot:1
+15 NEW INODE,NODE2,ZNODE
SET NODE2=$GET(^PSDRUG(+PSS(1),2))
SET INODE=$GET(^("I"))
SET ZNODE=$GET(^(0))
+16 IF +$GET(PSSFL)>0
IF +INODE>0
IF +INODE'>PSSFL
QUIT
+17 IF $EXTRACT(PSS,1,$LENGTH(PSSFT))'[PSSFT
QUIT
+18 SET ^TMP($JOB,LIST,+PSS(1),.01)=$PIECE(ZNODE,"^")
SET CNT=CNT+1
+19 SET ^TMP($JOB,LIST,"AIU",$PIECE(ZNODE,"^"),+PSS(1))=""
End DoDot:1
+20 SET ^TMP($JOB,LIST,0)=$SELECT(CNT>0:CNT,1:"-1^NO DATA FOUND")
+21 QUIT
+22 ;
IU ;
+1 ;PSSFL - Inactive flag - "" - All entries
+2 ; FileMan Date - Only entries with no Inactive Date or an Inactive Date greater than this date.
+3 ;LIST - Subscript of ^TMP array in the form ^TMP($J,LIST,Field Number where Field Number is the Field Number of the data
+4 ; piece being returned.
+5 ;Returns NAME field (#.01) of DRUG file (#50).
+6 IF $GET(LIST)']""
QUIT
+7 KILL ^TMP($JOB,LIST)
+8 NEW PSS,CNT
+9 SET CNT=0
SET PSS=""
FOR
SET PSS=$ORDER(^PSDRUG("IU",PSS))
if PSS=""
QUIT
IF PSS'["O"&(PSS'["U")&(PSS'["I")&(PSS'["N")
SET PSS(1)=0
FOR
SET PSS(1)=$ORDER(^PSDRUG("IU",PSS,PSS(1)))
if 'PSS(1)
QUIT
Begin DoDot:1
+10 NEW INODE,ZNODE
SET ZNODE=$GET(^PSDRUG(+PSS(1),0))
SET INODE=$GET(^("I"))
+11 IF +$GET(PSSFL)>0
IF +INODE>0
IF +INODE'>PSSFL
QUIT
+12 SET ^TMP($JOB,LIST,+PSS(1),.01)=$PIECE(ZNODE,"^")
SET CNT=CNT+1
+13 SET ^TMP($JOB,LIST,"IU",$PIECE(ZNODE,"^"),+PSS(1))=""
End DoDot:1
+14 SET ^TMP($JOB,LIST,0)=$SELECT(CNT>0:CNT,1:"-1^NO DATA FOUND")
+15 QUIT
