- 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 Feb 18, 2025@23:55:45 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
