PSS50ATC ;BIR/LDT - API INFORMATION FROM FILE 50; 23 Mar 04
;;1.0;PHARMACY DATA MANAGEMENT;**85**;9/30/97
;
;External reference to PS(57.5 supported by DBIA 2112
ATC ;
;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,PSSP50,SCR,PSS,PSSMLCT,PSSAXX,PSSAXX1,PSSAXX2,PSSAXXOK
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)]"") 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 PSSAXXOK=0 F PSSAXX=0:0 S PSSAXX=$O(^PSDRUG(+PSSIEN2,212,"AC",PSSAXX)) Q:'PSSAXX!(PSSAXXOK) S PSSAXX1="" F S PSSAXX1=$O(^PSDRUG(+PSSIEN2,212,"AC",PSSAXX,PSSAXX1)) Q:PSSAXX1=""!(PSSAXXOK) D
..F PSSAXX2=0:0 S PSSAXX2=$O(^PSDRUG(+PSSIEN2,212,"AC",PSSAXX,PSSAXX1,PSSAXX2)) Q:'PSSAXX2!(PSSAXXOK) I $D(^PSDRUG(+PSSIEN2,212,PSSAXX2,0)) S PSSAXXOK=1
.I 'PSSAXXOK S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
.S ^TMP($J,LIST,0)=1
.D SETSUB9^PSS50AQM(+PSSIEN2)
.K ^TMP("PSSP50",$J) D GETS^DIQ(50,+PSSIEN2,".01;212.2;212*","IE","^TMP(""PSSP50"",$J)") S PSS(1)=0
.F S PSS(1)=$O(^TMP("PSSP50",$J,50,PSS(1))) Q:'PSS(1) D SETATC D
..S (PSS(2),PSSMLCT)=0 F S PSS(2)=$O(^TMP("PSSP50",$J,50.0212,PSS(2))) Q:'PSS(2) S PSSMLCT=PSSMLCT+1 D SETATC2
..S ^TMP($J,LIST,+PSS(1),"ATC",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 N PSSXX S PSSXX=0 F S PSSXX=$O(^TMP("DILIST",$J,PSSXX)) Q:'PSSXX D
..S PSSIEN=+^TMP("DILIST",$J,PSSXX,0)
..S PSSAXXOK=0 F PSSAXX=0:0 S PSSAXX=$O(^PSDRUG(+PSSIEN,212,"AC",PSSAXX)) Q:'PSSAXX!(PSSAXXOK) S PSSAXX1="" F S PSSAXX1=$O(^PSDRUG(+PSSIEN,212,"AC",PSSAXX,PSSAXX1)) Q:PSSAXX1=""!(PSSAXXOK) D
...F PSSAXX2=0:0 S PSSAXX2=$O(^PSDRUG(+PSSIEN,212,"AC",PSSAXX,PSSAXX1,PSSAXX2)) Q:'PSSAXX2!(PSSAXXOK) I $D(^PSDRUG(+PSSIEN,212,PSSAXX2,0)) S PSSAXXOK=1
..I 'PSSAXXOK Q
..S ^TMP($J,LIST,0)=$S('$G(^TMP($J,LIST,0)):1,1:$G(^TMP($J,LIST,0))+1)
..D SETSUB9^PSS50AQM(PSSIEN) K ^TMP("PSSP50",$J) D GETS^DIQ(50,+PSSIEN,".01;212.2;212*","IE","^TMP(""PSSP50"",$J)") S PSS(1)=0
..F S PSS(1)=$O(^TMP("PSSP50",$J,50,PSS(1))) Q:'PSS(1) D SETATC D
...S (PSS(2),PSSMLCT)=0 F S PSS(2)=$O(^TMP("PSSP50",$J,50.0212,PSS(2))) Q:'PSS(2) S PSSMLCT=PSSMLCT+1 D SETATC2
...S ^TMP($J,LIST,+PSS(1),"ATC",0)=$S($G(PSSMLCT):PSSMLCT,1:"-1^NO DATA FOUND")
I '$O(^TMP($J,LIST,0)) S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND"
K ^TMP("DILIST",$J),^TMP("PSSP50",$J)
Q
SETATC ;
S ^TMP($J,LIST,+PSS(1),.01)=$G(^TMP("PSSP50",$J,50,PSS(1),.01,"I"))
S ^TMP($J,LIST,+PSS(1),212.2)=$G(^TMP("PSSP50",$J,50,PSS(1),212.2,"I"))
S ^TMP($J,LIST,"AC",$G(^TMP("PSSP50",$J,50,PSS(1),.01,"I")),+PSS(1))=""
Q
;
SETATC2 ;
S ^TMP($J,LIST,+PSS(1),"ATC",+PSS(2),.01)=$S($G(^TMP("PSSP50",$J,50.0212,PSS(2),.01,"I"))="":"",1:$G(^TMP("PSSP50",$J,50.0212,PSS(2),.01,"I"))_"^"_$G(^TMP("PSSP50",$J,50.0212,PSS(2),.01,"E")))
S ^TMP($J,LIST,+PSS(1),"ATC",+PSS(2),1)=$G(^TMP("PSSP50",$J,50.0212,PSS(2),1,"I"))
Q
SETATCL ;
S ^TMP($J,LIST,+PSS(1),.01)=$P(^PSDRUG(PSS(1),0),"^")
S ^TMP($J,LIST,"AC",$P(^PSDRUG(+PSS(1),0),"^"),+PSS(1))=""
S ^TMP($J,LIST,+PSS(1),212.2)=$P($G(^PSDRUG(+PSS(1),8.5)),"^",2)
Q
SETATCLM ;
N PSS50212 S PSS50212=0
I $O(^PSDRUG(+PSS(1),212,0)) N PSSATCND,PSSAT212 D
.F PSSAT212=0:0 S PSSAT212=$O(^PSDRUG(+PSS(1),212,PSSAT212)) Q:'PSSAT212 D
..S PSSATCND=$G(^PSDRUG(+PSS(1),212,PSSAT212,0)) I $P(PSSATCND,"^")'="" S PSS50212=PSS50212+1 D
...S ^TMP($J,LIST,+PSS(1),"ATC",PSSAT212,.01)=$S($P(PSSATCND,"^")&($P($G(^PS(57.5,+$P(PSSATCND,"^"),0)),"^")'=""):$P(PSSATCND,"^")_"^"_$P($G(^PS(57.5,+$P(PSSATCND,"^"),0)),"^"),1:"")
...S ^TMP($J,LIST,+PSS(1),"ATC",PSSAT212,1)=$P(PSSATCND,"^",2)
S ^TMP($J,LIST,+PSS(1),"ATC",0)=$S(PSS50212:PSS50212,1:"-1^NO DATA FOUND")
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
.S PSSAXXOK=0 F PSSAXX=0:0 S PSSAXX=$O(^PSDRUG(PSS(1),212,"AC",PSSAXX)) Q:'PSSAXX!(PSSAXXOK) S PSSAXX1="" F S PSSAXX1=$O(^PSDRUG(PSS(1),212,"AC",PSSAXX,PSSAXX1)) Q:PSSAXX1=""!(PSSAXXOK) D
..F PSSAXX2=0:0 S PSSAXX2=$O(^PSDRUG(PSS(1),212,"AC",PSSAXX,PSSAXX1,PSSAXX2)) Q:'PSSAXX2!(PSSAXXOK) I $D(^PSDRUG(PSS(1),212,PSSAXX2,0)) S PSSAXXOK=1
.I 'PSSAXXOK Q
.D SETSUB9^PSS50AQM(PSS(1))
.D SETATCL,SETATCLM
.S PSSENCT=PSSENCT+1
S ^TMP($J,LIST,0)=$S($G(PSSENCT):$G(PSSENCT),1:"-1^NO DATA FOUND")
Q
SETSYN2 ;
S ^TMP($J,LIST,+PSS(1),"SYN",+PSS(2),.01)=$G(^TMP("PSSP50",$J,50.1,PSS(2),.01,"I"))
S ^TMP($J,LIST,+PSS(1),"SYN",+PSS(2),1)=$S($G(^TMP("PSSP50",$J,50.1,PSS(2),1,"I"))="":"",1:^TMP("PSSP50",$J,50.1,PSS(2),1,"I")_"^"_^TMP("PSSP50",$J,50.1,PSS(2),1,"E"))
S ^TMP($J,LIST,+PSS(1),"SYN",+PSS(2),2)=$G(^TMP("PSSP50",$J,50.1,PSS(2),2,"I"))
S ^TMP($J,LIST,+PSS(1),"SYN",+PSS(2),400)=$G(^TMP("PSSP50",$J,50.1,PSS(2),400,"I"))
N PSSUTNX S PSSUTNX=$G(^TMP("PSSP50",$J,50.1,PSS(2),401,"I"))
S ^TMP($J,LIST,+PSS(1),"SYN",+PSS(2),401)=$S($G(PSSUTNX)="":"",1:$G(^TMP("PSSP50",$J,50.1,PSS(2),401,"I"))_"^"_$G(^TMP("PSSP50",$J,50.1,PSS(2),401,"E")))
I PSSUTNX'="" S ^TMP($J,LIST,+PSS(1),"SYN",+PSS(2),401)=^TMP($J,LIST,+PSS(1),"SYN",+PSS(2),401)_"^"_$P($G(^DIC(51.5,PSSUTNX,0)),"^",2)
S ^TMP($J,LIST,+PSS(1),"SYN",+PSS(2),402)=$G(^TMP("PSSP50",$J,50.1,PSS(2),402,"I"))
S ^TMP($J,LIST,+PSS(1),"SYN",+PSS(2),403)=$G(^TMP("PSSP50",$J,50.1,PSS(2),403,"I"))
S ^TMP($J,LIST,+PSS(1),"SYN",+PSS(2),404)=$G(^TMP("PSSP50",$J,50.1,PSS(2),404,"I"))
S ^TMP($J,LIST,+PSS(1),"SYN",+PSS(2),405)=$G(^TMP("PSSP50",$J,50.1,PSS(2),405,"I"))
Q
;
SETINV ;
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,+PSS(1),11)=$G(^TMP("PSSP50",$J,50,PSS(1),11,"I"))
N PSSUTN S PSSUTN=$G(^TMP("PSSP50",$J,50,PSS(1),12,"I"))
S ^TMP($J,LIST,+PSS(1),12)=$S($G(PSSUTN)="":"",1:$G(^TMP("PSSP50",$J,50,PSS(1),12,"I"))_"^"_$G(^TMP("PSSP50",$J,50,PSS(1),12,"E")))
I PSSUTN'="" S ^TMP($J,LIST,+PSS(1),12)=^TMP($J,LIST,+PSS(1),12)_"^"_$P($G(^DIC(51.5,PSSUTN,0)),"^",2)
S ^TMP($J,LIST,+PSS(1),13)=$G(^TMP("PSSP50",$J,50,PSS(1),13,"I"))
S ^TMP($J,LIST,+PSS(1),14)=$G(^TMP("PSSP50",$J,50,PSS(1),14,"I"))
S ^TMP($J,LIST,+PSS(1),15)=$G(^TMP("PSSP50",$J,50,PSS(1),15,"I"))
S ^TMP($J,LIST,+PSS(1),16)=$G(^TMP("PSSP50",$J,50,PSS(1),16,"I"))
S ^TMP($J,LIST,+PSS(1),17)=$G(^TMP("PSSP50",$J,50,PSS(1),17,"I"))
S ^TMP($J,LIST,+PSS(1),14.5)=$G(^TMP("PSSP50",$J,50,PSS(1),14.5,"I"))
S ^TMP($J,LIST,+PSS(1),17.1)=$S($G(^TMP("PSSP50",$J,50,PSS(1),17.1,"I"))="":"",1:^TMP("PSSP50",$J,50,PSS(1),17.1,"I")_"^"_$G(^TMP("PSSP50",$J,50,PSS(1),17.1,"E")))
S ^TMP($J,LIST,+PSS(1),50)=$G(^TMP("PSSP50",$J,50,PSS(1),50,"I"))
Q
SETIFC ;
S ^TMP($J,LIST,+PSS(1),"IFC",+PSS(2),.01)=$S($G(^TMP("PSSP50",$J,50.0441,PSS(2),.01,"I"))="":"",1:^TMP("PSSP50",$J,50.0441,PSS(2),.01,"I"))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSS50ATC 8221 printed Apr 09, 2024@21:37:02 Page 2
PSS50ATC ;BIR/LDT - API INFORMATION FROM FILE 50; 23 Mar 04
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**85**;9/30/97
+2 ;
+3 ;External reference to PS(57.5 supported by DBIA 2112
ATC ;
+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,PSSP50,SCR,PSS,PSSMLCT,PSSAXX,PSSAXX1,PSSAXX2,PSSAXXOK
+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 SET SCR("S")=""
+15 IF +$GET(PSSFL)>0!($GET(PSSPK)]"")
NEW PSS5ND,PSSZ3,PSSZ4
DO SETSCRN^PSS50A
+16 IF +$GET(PSSIEN)>0
NEW PSSIEN2
SET PSSIEN2=$$FIND1^DIC(50,"","A","`"_PSSIEN,,SCR("S"),"")
Begin DoDot:1
+17 KILL ^TMP("DIERR",$JOB)
+18 IF +PSSIEN2'>0
SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
QUIT
+19 SET PSSAXXOK=0
FOR PSSAXX=0:0
SET PSSAXX=$ORDER(^PSDRUG(+PSSIEN2,212,"AC",PSSAXX))
if 'PSSAXX!(PSSAXXOK)
QUIT
SET PSSAXX1=""
FOR
SET PSSAXX1=$ORDER(^PSDRUG(+PSSIEN2,212,"AC",PSSAXX,PSSAXX1))
if PSSAXX1=""!(PSSAXXOK)
QUIT
Begin DoDot:2
+20 FOR PSSAXX2=0:0
SET PSSAXX2=$ORDER(^PSDRUG(+PSSIEN2,212,"AC",PSSAXX,PSSAXX1,PSSAXX2))
if 'PSSAXX2!(PSSAXXOK)
QUIT
IF $DATA(^PSDRUG(+PSSIEN2,212,PSSAXX2,0))
SET PSSAXXOK=1
End DoDot:2
+21 IF 'PSSAXXOK
SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
QUIT
+22 SET ^TMP($JOB,LIST,0)=1
+23 DO SETSUB9^PSS50AQM(+PSSIEN2)
+24 KILL ^TMP("PSSP50",$JOB)
DO GETS^DIQ(50,+PSSIEN2,".01;212.2;212*","IE","^TMP(""PSSP50"",$J)")
SET PSS(1)=0
+25 FOR
SET PSS(1)=$ORDER(^TMP("PSSP50",$JOB,50,PSS(1)))
if 'PSS(1)
QUIT
DO SETATC
Begin DoDot:2
+26 SET (PSS(2),PSSMLCT)=0
FOR
SET PSS(2)=$ORDER(^TMP("PSSP50",$JOB,50.0212,PSS(2)))
if 'PSS(2)
QUIT
SET PSSMLCT=PSSMLCT+1
DO SETATC2
+27 SET ^TMP($JOB,LIST,+PSS(1),"ATC",0)=$SELECT($GET(PSSMLCT):PSSMLCT,1:"-1^NO DATA FOUND")
End DoDot:2
End DoDot:1
KILL ^TMP("PSSP50",$JOB)
QUIT
+28 IF $GET(PSSIEN)'=""
SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
QUIT
+29 IF $GET(PSSFT)]""
Begin DoDot:1
+30 IF PSSFT["??"
DO LOOP
QUIT
+31 KILL ^TMP("DILIST",$JOB)
+32 DO FIND^DIC(50,,"@;.01","QP",PSSFT,,"B",SCR("S"),,"")
+33 IF +$GET(^TMP("DILIST",$JOB,0))=0
SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
QUIT
+34 IF +^TMP("DILIST",$JOB,0)>0
NEW PSSXX
SET PSSXX=0
FOR
SET PSSXX=$ORDER(^TMP("DILIST",$JOB,PSSXX))
if 'PSSXX
QUIT
Begin DoDot:2
+35 SET PSSIEN=+^TMP("DILIST",$JOB,PSSXX,0)
+36 SET PSSAXXOK=0
FOR PSSAXX=0:0
SET PSSAXX=$ORDER(^PSDRUG(+PSSIEN,212,"AC",PSSAXX))
if 'PSSAXX!(PSSAXXOK)
QUIT
SET PSSAXX1=""
FOR
SET PSSAXX1=$ORDER(^PSDRUG(+PSSIEN,212,"AC",PSSAXX,PSSAXX1))
if PSSAXX1=""!(PSSAXXOK)
QUIT
Begin DoDot:3
+37 FOR PSSAXX2=0:0
SET PSSAXX2=$ORDER(^PSDRUG(+PSSIEN,212,"AC",PSSAXX,PSSAXX1,PSSAXX2))
if 'PSSAXX2!(PSSAXXOK)
QUIT
IF $DATA(^PSDRUG(+PSSIEN,212,PSSAXX2,0))
SET PSSAXXOK=1
End DoDot:3
+38 IF 'PSSAXXOK
QUIT
+39 SET ^TMP($JOB,LIST,0)=$SELECT('$GET(^TMP($JOB,LIST,0)):1,1:$GET(^TMP($JOB,LIST,0))+1)
+40 DO SETSUB9^PSS50AQM(PSSIEN)
KILL ^TMP("PSSP50",$JOB)
DO GETS^DIQ(50,+PSSIEN,".01;212.2;212*","IE","^TMP(""PSSP50"",$J)")
SET PSS(1)=0
+41 FOR
SET PSS(1)=$ORDER(^TMP("PSSP50",$JOB,50,PSS(1)))
if 'PSS(1)
QUIT
DO SETATC
Begin DoDot:3
+42 SET (PSS(2),PSSMLCT)=0
FOR
SET PSS(2)=$ORDER(^TMP("PSSP50",$JOB,50.0212,PSS(2)))
if 'PSS(2)
QUIT
SET PSSMLCT=PSSMLCT+1
DO SETATC2
+43 SET ^TMP($JOB,LIST,+PSS(1),"ATC",0)=$SELECT($GET(PSSMLCT):PSSMLCT,1:"-1^NO DATA FOUND")
End DoDot:3
End DoDot:2
End DoDot:1
+44 IF '$ORDER(^TMP($JOB,LIST,0))
SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
+45 KILL ^TMP("DILIST",$JOB),^TMP("PSSP50",$JOB)
+46 QUIT
SETATC ;
+1 SET ^TMP($JOB,LIST,+PSS(1),.01)=$GET(^TMP("PSSP50",$JOB,50,PSS(1),.01,"I"))
+2 SET ^TMP($JOB,LIST,+PSS(1),212.2)=$GET(^TMP("PSSP50",$JOB,50,PSS(1),212.2,"I"))
+3 SET ^TMP($JOB,LIST,"AC",$GET(^TMP("PSSP50",$JOB,50,PSS(1),.01,"I")),+PSS(1))=""
+4 QUIT
+5 ;
SETATC2 ;
+1 SET ^TMP($JOB,LIST,+PSS(1),"ATC",+PSS(2),.01)=$SELECT($GET(^TMP("PSSP50",$JOB,50.0212,PSS(2),.01,"I"))="":"",1:$GET(^TMP("PSSP50",$JOB,50.0212,PSS(2),.01,"I"))_"^"_$GET(^TMP("PSSP50",$JOB,50.0212,PSS(2),.01,"E")))
+2 SET ^TMP($JOB,LIST,+PSS(1),"ATC",+PSS(2),1)=$GET(^TMP("PSSP50",$JOB,50.0212,PSS(2),1,"I"))
+3 QUIT
SETATCL ;
+1 SET ^TMP($JOB,LIST,+PSS(1),.01)=$PIECE(^PSDRUG(PSS(1),0),"^")
+2 SET ^TMP($JOB,LIST,"AC",$PIECE(^PSDRUG(+PSS(1),0),"^"),+PSS(1))=""
+3 SET ^TMP($JOB,LIST,+PSS(1),212.2)=$PIECE($GET(^PSDRUG(+PSS(1),8.5)),"^",2)
+4 QUIT
SETATCLM ;
+1 NEW PSS50212
SET PSS50212=0
+2 IF $ORDER(^PSDRUG(+PSS(1),212,0))
NEW PSSATCND,PSSAT212
Begin DoDot:1
+3 FOR PSSAT212=0:0
SET PSSAT212=$ORDER(^PSDRUG(+PSS(1),212,PSSAT212))
if 'PSSAT212
QUIT
Begin DoDot:2
+4 SET PSSATCND=$GET(^PSDRUG(+PSS(1),212,PSSAT212,0))
IF $PIECE(PSSATCND,"^")'=""
SET PSS50212=PSS50212+1
Begin DoDot:3
+5 SET ^TMP($JOB,LIST,+PSS(1),"ATC",PSSAT212,.01)=$SELECT($PIECE(PSSATCND,"^")&($PIECE($GET(^PS(57.5,+$PIECE(PSSATCND,"^"),0)),"^")'=""):$PIECE(PSSATCND,"^")_"^"_$PIECE($GET(^PS(57.5,+$PIECE(PSSATCND,"^"),0)),"^"),1:"")
+6 SET ^TMP($JOB,LIST,+PSS(1),"ATC",PSSAT212,1)=$PIECE(PSSATCND,"^",2)
End DoDot:3
End DoDot:2
End DoDot:1
+7 SET ^TMP($JOB,LIST,+PSS(1),"ATC",0)=$SELECT(PSS50212:PSS50212,1:"-1^NO DATA FOUND")
+8 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 ;I $G(PSSRTOI)=1,'$P($G(^PSDRUG(PSS(1),2)),"^") Q
+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 SET PSSAXXOK=0
FOR PSSAXX=0:0
SET PSSAXX=$ORDER(^PSDRUG(PSS(1),212,"AC",PSSAXX))
if 'PSSAXX!(PSSAXXOK)
QUIT
SET PSSAXX1=""
FOR
SET PSSAXX1=$ORDER(^PSDRUG(PSS(1),212,"AC",PSSAXX,PSSAXX1))
if PSSAXX1=""!(PSSAXXOK)
QUIT
Begin DoDot:2
+11 FOR PSSAXX2=0:0
SET PSSAXX2=$ORDER(^PSDRUG(PSS(1),212,"AC",PSSAXX,PSSAXX1,PSSAXX2))
if 'PSSAXX2!(PSSAXXOK)
QUIT
IF $DATA(^PSDRUG(PSS(1),212,PSSAXX2,0))
SET PSSAXXOK=1
End DoDot:2
+12 IF 'PSSAXXOK
QUIT
+13 DO SETSUB9^PSS50AQM(PSS(1))
+14 DO SETATCL
DO SETATCLM
+15 SET PSSENCT=PSSENCT+1
End DoDot:1
+16 SET ^TMP($JOB,LIST,0)=$SELECT($GET(PSSENCT):$GET(PSSENCT),1:"-1^NO DATA FOUND")
+17 QUIT
SETSYN2 ;
+1 SET ^TMP($JOB,LIST,+PSS(1),"SYN",+PSS(2),.01)=$GET(^TMP("PSSP50",$JOB,50.1,PSS(2),.01,"I"))
+2 SET ^TMP($JOB,LIST,+PSS(1),"SYN",+PSS(2),1)=$SELECT($GET(^TMP("PSSP50",$JOB,50.1,PSS(2),1,"I"))="":"",1:^TMP("PSSP50",$JOB,50.1,PSS(2),1,"I")_"^"_^TMP("PSSP50",$JOB,50.1,PSS(2),1,"E"))
+3 SET ^TMP($JOB,LIST,+PSS(1),"SYN",+PSS(2),2)=$GET(^TMP("PSSP50",$JOB,50.1,PSS(2),2,"I"))
+4 SET ^TMP($JOB,LIST,+PSS(1),"SYN",+PSS(2),400)=$GET(^TMP("PSSP50",$JOB,50.1,PSS(2),400,"I"))
+5 NEW PSSUTNX
SET PSSUTNX=$GET(^TMP("PSSP50",$JOB,50.1,PSS(2),401,"I"))
+6 SET ^TMP($JOB,LIST,+PSS(1),"SYN",+PSS(2),401)=$SELECT($GET(PSSUTNX)="":"",1:$GET(^TMP("PSSP50",$JOB,50.1,PSS(2),401,"I"))_"^"_$GET(^TMP("PSSP50",$JOB,50.1,PSS(2),401,"E")))
+7 IF PSSUTNX'=""
SET ^TMP($JOB,LIST,+PSS(1),"SYN",+PSS(2),401)=^TMP($JOB,LIST,+PSS(1),"SYN",+PSS(2),401)_"^"_$PIECE($GET(^DIC(51.5,PSSUTNX,0)),"^",2)
+8 SET ^TMP($JOB,LIST,+PSS(1),"SYN",+PSS(2),402)=$GET(^TMP("PSSP50",$JOB,50.1,PSS(2),402,"I"))
+9 SET ^TMP($JOB,LIST,+PSS(1),"SYN",+PSS(2),403)=$GET(^TMP("PSSP50",$JOB,50.1,PSS(2),403,"I"))
+10 SET ^TMP($JOB,LIST,+PSS(1),"SYN",+PSS(2),404)=$GET(^TMP("PSSP50",$JOB,50.1,PSS(2),404,"I"))
+11 SET ^TMP($JOB,LIST,+PSS(1),"SYN",+PSS(2),405)=$GET(^TMP("PSSP50",$JOB,50.1,PSS(2),405,"I"))
+12 QUIT
+13 ;
SETINV ;
+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 SET ^TMP($JOB,LIST,+PSS(1),11)=$GET(^TMP("PSSP50",$JOB,50,PSS(1),11,"I"))
+4 NEW PSSUTN
SET PSSUTN=$GET(^TMP("PSSP50",$JOB,50,PSS(1),12,"I"))
+5 SET ^TMP($JOB,LIST,+PSS(1),12)=$SELECT($GET(PSSUTN)="":"",1:$GET(^TMP("PSSP50",$JOB,50,PSS(1),12,"I"))_"^"_$GET(^TMP("PSSP50",$JOB,50,PSS(1),12,"E")))
+6 IF PSSUTN'=""
SET ^TMP($JOB,LIST,+PSS(1),12)=^TMP($JOB,LIST,+PSS(1),12)_"^"_$PIECE($GET(^DIC(51.5,PSSUTN,0)),"^",2)
+7 SET ^TMP($JOB,LIST,+PSS(1),13)=$GET(^TMP("PSSP50",$JOB,50,PSS(1),13,"I"))
+8 SET ^TMP($JOB,LIST,+PSS(1),14)=$GET(^TMP("PSSP50",$JOB,50,PSS(1),14,"I"))
+9 SET ^TMP($JOB,LIST,+PSS(1),15)=$GET(^TMP("PSSP50",$JOB,50,PSS(1),15,"I"))
+10 SET ^TMP($JOB,LIST,+PSS(1),16)=$GET(^TMP("PSSP50",$JOB,50,PSS(1),16,"I"))
+11 SET ^TMP($JOB,LIST,+PSS(1),17)=$GET(^TMP("PSSP50",$JOB,50,PSS(1),17,"I"))
+12 SET ^TMP($JOB,LIST,+PSS(1),14.5)=$GET(^TMP("PSSP50",$JOB,50,PSS(1),14.5,"I"))
+13 SET ^TMP($JOB,LIST,+PSS(1),17.1)=$SELECT($GET(^TMP("PSSP50",$JOB,50,PSS(1),17.1,"I"))="":"",1:^TMP("PSSP50",$JOB,50,PSS(1),17.1,"I")_"^"_$GET(^TMP("PSSP50",$JOB,50,PSS(1),17.1,"E")))
+14 SET ^TMP($JOB,LIST,+PSS(1),50)=$GET(^TMP("PSSP50",$JOB,50,PSS(1),50,"I"))
+15 QUIT
SETIFC ;
+1 SET ^TMP($JOB,LIST,+PSS(1),"IFC",+PSS(2),.01)=$SELECT($GET(^TMP("PSSP50",$JOB,50.0441,PSS(2),.01,"I"))="":"",1:^TMP("PSSP50",$JOB,50.0441,PSS(2),.01,"I"))
+2 QUIT
