- PSS50CMP ;BIR/RTR - CONTINUATION OF API FOR INFORMATION FROM FILE 50; 5 Sep 03
- ;;1.0;PHARMACY DATA MANAGEMENT;**85**;9/30/97
- ;
- CMOP ;
- ;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.
- ;Returns zero node of 50
- 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
- .D SETSUB5^PSS50AQM(+PSSIEN2)
- .K ^TMP("PSSP50",$J) D GETS^DIQ(50,+PSSIEN2,".01;213;214*;215;28","IE","^TMP(""PSSP50"",$J)") S PSS(1)=0
- .F S PSS(1)=$O(^TMP("PSSP50",$J,50,PSS(1))) Q:'PSS(1) D SETCMOP D
- ..S (PSS(2),PSSMLCT)=0 F S PSS(2)=$O(^TMP("PSSP50",$J,50.0214,PSS(2))) Q:'PSS(2) S PSSMLCT=PSSMLCT+1 D SETACT
- ..S ^TMP($J,LIST,+PSS(1),"AL",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 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)
- ..D SETSUB5^PSS50AQM(PSSIEN) K ^TMP("PSSP50",$J) D GETS^DIQ(50,+PSSIEN,".01;213;214*;215;28","IE","^TMP(""PSSP50"",$J)") S PSS(1)=0
- ..F S PSS(1)=$O(^TMP("PSSP50",$J,50,PSS(1))) Q:'PSS(1) D SETCMOP D
- ...S (PSS(2),PSSMLCT)=0 F S PSS(2)=$O(^TMP("PSSP50",$J,50.0214,PSS(2))) Q:'PSS(2) S PSSMLCT=PSSMLCT+1 D SETACT
- ...S ^TMP($J,LIST,+PSS(1),"AL",0)=$S($G(PSSMLCT):PSSMLCT,1:"-1^NO DATA FOUND")
- K ^TMP("DILIST",$J),^TMP("PSSP50",$J)
- Q
- SETCMOP ;
- 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),213)=$S($G(^TMP("PSSP50",$J,50,PSS(1),213,"I"))="":"",1:^TMP("PSSP50",$J,50,PSS(1),213,"I")_"^"_$G(^TMP("PSSP50",$J,50,PSS(1),213,"E")))
- S ^TMP($J,LIST,+PSS(1),215)=$G(^TMP("PSSP50",$J,50,PSS(1),215,"I"))
- S ^TMP($J,LIST,+PSS(1),28)=$S($G(^TMP("PSSP50",$J,50,PSS(1),28,"I"))="":"",1:^TMP("PSSP50",$J,50,PSS(1),28,"I")_"^"_$G(^TMP("PSSP50",$J,50,PSS(1),28,"E")))
- Q
- SETACT ;
- S ^TMP($J,LIST,+PSS(1),"AL",+PSS(2),.01)=$S($G(^TMP("PSSP50",$J,50.0214,PSS(2),.01,"I"))="":"",1:^TMP("PSSP50",$J,50.0214,PSS(2),.01,"I")_"^"_$G(^TMP("PSSP50",$J,50.0214,PSS(2),.01,"E")))
- S ^TMP($J,LIST,+PSS(1),"AL",+PSS(2),1)=$S($G(^TMP("PSSP50",$J,50.0214,PSS(2),1,"I"))="":"",1:^TMP("PSSP50",$J,50.0214,PSS(2),1,"I")_"^"_$G(^TMP("PSSP50",$J,50.0214,PSS(2),1,"E")))
- S ^TMP($J,LIST,+PSS(1),"AL",+PSS(2),2)=$S($G(^TMP("PSSP50",$J,50.0214,PSS(2),2,"I"))="":"",1:^TMP("PSSP50",$J,50.0214,PSS(2),2,"I")_"^"_$G(^TMP("PSSP50",$J,50.0214,PSS(2),2,"E")))
- S ^TMP($J,LIST,+PSS(1),"AL",+PSS(2),3)=$G(^TMP("PSSP50",$J,50.0214,PSS(2),3,"I"))
- S ^TMP($J,LIST,+PSS(1),"AL",+PSS(2),4)=$G(^TMP("PSSP50",$J,50.0214,PSS(2),4,"I"))
- S ^TMP($J,LIST,+PSS(1),"AL",+PSS(2),5)=$G(^TMP("PSSP50",$J,50.0214,PSS(2),5,"I"))
- Q
- ;
- LOOP ;
- N PSS50DD9,PSS50D10,PSS50D11,PSS50ER9,PSS50E10,PSS50E11,PSS28OPD,PSS213PD,PSS5021X
- D FIELD^DID(50,28,"Z","POINTER","PSS50DD9","PSS50ER9") S PSS28OPD=$G(PSS50DD9("POINTER"))
- D FIELD^DID(50,213,"Z","POINTER","PSS50D10","PSS50E10") S PSS213PD=$G(PSS50D10("POINTER"))
- D FIELD^DID(50.0214,1,"Z","POINTER","PSS50D11","PSS50E11") S PSS5021X=$G(PSS50D11("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 SETSUB5^PSS50AQM(PSS(1))
- .D SETCMQ,SETACQ
- .S PSSENCT=PSSENCT+1
- S ^TMP($J,LIST,0)=$S($G(PSSENCT):$G(PSSENCT),1:"-1^NO DATA FOUND")
- Q
- ;
- SETCMQ ;
- N PSSCMP3,PSSCMP5,PSSCMP6
- S ^TMP($J,LIST,+PSS(1),.01)=$P(^PSDRUG(PSS(1),0),"^")
- S ^TMP($J,LIST,"B",$P(^PSDRUG(+PSS(1),0),"^"),+PSS(1))=""
- N PSS28OP S PSS28OP=$P($G(^PSDRUG(+PSS(1),6)),"^") D
- .I PSS28OP'="",PSS28OPD'="",PSS28OPD[(PSS28OP_":") S ^TMP($J,LIST,+PSS(1),28)=PSS28OP_"^"_$P($E(PSS28OPD,$F(PSS28OPD,(PSS28OP_":")),999),";") Q
- .S ^TMP($J,LIST,+PSS(1),28)=""
- N PSS213P S PSS213P=$P($G(^PSDRUG(+PSS(1),3)),"^") D
- .I PSS213P'="",PSS213PD'="",PSS213PD[(PSS213P_":") S ^TMP($J,LIST,+PSS(1),213)=PSS213P_"^"_$P($E(PSS213PD,$F(PSS213PD,(PSS213P_":")),999),";") Q
- .S ^TMP($J,LIST,+PSS(1),213)=""
- S ^TMP($J,LIST,+PSS(1),215)=$P($G(^PSDRUG(+PSS(1),5)),"^")
- Q
- ;
- SETACQ ;
- N PSS504C S PSS504C=0
- I $O(^PSDRUG(+PSS(1),4,0)) N PSS504,PSS504ND D
- .F PSS504=0:0 S PSS504=$O(^PSDRUG(+PSS(1),4,PSS504)) Q:'PSS504 D
- ..S PSS504ND=$G(^PSDRUG(+PSS(1),4,PSS504,0)) I $P(PSS504ND,"^")'="" S PSS504C=PSS504C+1 D
- ...N Y S (^TMP($J,LIST,+PSS(1),"AL",PSS504,.01),Y)=$P(PSS504ND,"^") X ^DD("DD") S ^TMP($J,LIST,+PSS(1),"AL",PSS504,.01)=^TMP($J,LIST,+PSS(1),"AL",PSS504,.01)_"^"_$G(Y)
- ...N PSS5021 S PSS5021=$P(PSS504ND,"^",2) D
- ....I PSS5021'="",PSS5021X'="",PSS5021X[(PSS5021_":") S ^TMP($J,LIST,+PSS(1),"AL",PSS504,1)=PSS5021_"^"_$P($E(PSS5021X,$F(PSS5021X,(PSS5021_":")),999),";") Q
- ....S ^TMP($J,LIST,+PSS(1),"AL",PSS504,1)=""
- ...N PSS200,PSSA200 S PSS200=$P(PSS504ND,"^",3) I PSS200 D GETS^DIQ(50.0214,+PSS504_","_+PSS(1),2,"E","PSSA200") S ^TMP($J,LIST,+PSS(1),"AL",PSS504,2)=PSS200_"^"_$G(PSSA200(50.0214,+PSS504_","_+PSS(1)_",",2,"E"))
- ...S ^TMP($J,LIST,+PSS(1),"AL",PSS504,3)=$P(PSS504ND,"^",4)
- ...S ^TMP($J,LIST,+PSS(1),"AL",PSS504,4)=$P(PSS504ND,"^",5)
- ...S ^TMP($J,LIST,+PSS(1),"AL",PSS504,5)=$P(PSS504ND,"^",6)
- S ^TMP($J,LIST,+PSS(1),"AL",0)=$S(PSS504C:PSS504C,1:"-1^NO DATA FOUND")
- Q
-
- PSS50CMP ;BIR/RTR - CONTINUATION OF API FOR INFORMATION FROM FILE 50; 5 Sep 03
- +1 ;;1.0;PHARMACY DATA MANAGEMENT;**85**;9/30/97
- +2 ;
- CMOP ;
- +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 ;Returns zero node of 50
- +12 NEW DIERR,ZZERR,PSSP50,SCR,PSS,PSSMLCT
- +13 IF $GET(LIST)']""
- QUIT
- +14 KILL ^TMP($JOB,LIST)
- +15 IF +$GET(PSSIEN)'>0
- IF ($GET(PSSFT)']"")
- SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
- QUIT
- +16 SET SCR("S")=""
- +17 IF +$GET(PSSFL)>0!($GET(PSSPK)]"")!($GET(PSSRTOI)=1)
- NEW PSS5ND,PSSZ3,PSSZ4
- DO SETSCRN^PSS50A
- +18 IF +$GET(PSSIEN)>0
- NEW PSSIEN2
- SET PSSIEN2=$$FIND1^DIC(50,"","A","`"_PSSIEN,,SCR("S"),"")
- Begin DoDot:1
- +19 KILL ^TMP("DIERR",$JOB)
- +20 IF +PSSIEN2'>0
- SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
- QUIT
- +21 SET ^TMP($JOB,LIST,0)=1
- +22 DO SETSUB5^PSS50AQM(+PSSIEN2)
- +23 KILL ^TMP("PSSP50",$JOB)
- DO GETS^DIQ(50,+PSSIEN2,".01;213;214*;215;28","IE","^TMP(""PSSP50"",$J)")
- SET PSS(1)=0
- +24 FOR
- SET PSS(1)=$ORDER(^TMP("PSSP50",$JOB,50,PSS(1)))
- IF 'PSS(1)
- QUIT
- DO SETCMOP
- Begin DoDot:2
- +25 SET (PSS(2),PSSMLCT)=0
- FOR
- SET PSS(2)=$ORDER(^TMP("PSSP50",$JOB,50.0214,PSS(2)))
- IF 'PSS(2)
- QUIT
- SET PSSMLCT=PSSMLCT+1
- DO SETACT
- +26 SET ^TMP($JOB,LIST,+PSS(1),"AL",0)=$SELECT($GET(PSSMLCT):PSSMLCT,1:"-1^NO DATA FOUND")
- End DoDot:2
- End DoDot:1
- KILL ^TMP("PSSP50",$JOB)
- QUIT
- +27 IF $GET(PSSIEN)'=""
- SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
- QUIT
- +28 IF $GET(PSSFT)]""
- Begin DoDot:1
- +29 IF PSSFT["??"
- DO LOOP
- QUIT
- +30 KILL ^TMP("DILIST",$JOB)
- +31 DO FIND^DIC(50,,"@;.01","QP",PSSFT,,"B",SCR("S"),,"")
- +32 IF +$GET(^TMP("DILIST",$JOB,0))=0
- SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
- QUIT
- +33 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
- +34 SET PSSIEN=+^TMP("DILIST",$JOB,PSSXX,0)
- +35 DO SETSUB5^PSS50AQM(PSSIEN)
- KILL ^TMP("PSSP50",$JOB)
- DO GETS^DIQ(50,+PSSIEN,".01;213;214*;215;28","IE","^TMP(""PSSP50"",$J)")
- SET PSS(1)=0
- +36 FOR
- SET PSS(1)=$ORDER(^TMP("PSSP50",$JOB,50,PSS(1)))
- IF 'PSS(1)
- QUIT
- DO SETCMOP
- Begin DoDot:3
- +37 SET (PSS(2),PSSMLCT)=0
- FOR
- SET PSS(2)=$ORDER(^TMP("PSSP50",$JOB,50.0214,PSS(2)))
- IF 'PSS(2)
- QUIT
- SET PSSMLCT=PSSMLCT+1
- DO SETACT
- +38 SET ^TMP($JOB,LIST,+PSS(1),"AL",0)=$SELECT($GET(PSSMLCT):PSSMLCT,1:"-1^NO DATA FOUND")
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +39 KILL ^TMP("DILIST",$JOB),^TMP("PSSP50",$JOB)
- +40 QUIT
- SETCMOP ;
- +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),213)=$SELECT($GET(^TMP("PSSP50",$JOB,50,PSS(1),213,"I"))="":"",1:^TMP("PSSP50",$JOB,50,PSS(1),213,"I")_"^"_$GET(^TMP("PSSP50",$JOB,50,PSS(1),213,"E")))
- +4 SET ^TMP($JOB,LIST,+PSS(1),215)=$GET(^TMP("PSSP50",$JOB,50,PSS(1),215,"I"))
- +5 SET ^TMP($JOB,LIST,+PSS(1),28)=$SELECT($GET(^TMP("PSSP50",$JOB,50,PSS(1),28,"I"))="":"",1:^TMP("PSSP50",$JOB,50,PSS(1),28,"I")_"^"_$GET(^TMP("PSSP50",$JOB,50,PSS(1),28,"E")))
- +6 QUIT
- SETACT ;
- +1 SET ^TMP($JOB,LIST,+PSS(1),"AL",+PSS(2),.01)=$SELECT($GET(^TMP("PSSP50",$JOB,50.0214,PSS(2),.01,"I"))="":"",1:^TMP("PSSP50",$JOB,50.0214,PSS(2),.01,"I")_"^"_$GET(^TMP("PSSP50",$JOB,50.0214,PSS(2),.01,"E")))
- +2 SET ^TMP($JOB,LIST,+PSS(1),"AL",+PSS(2),1)=$SELECT($GET(^TMP("PSSP50",$JOB,50.0214,PSS(2),1,"I"))="":"",1:^TMP("PSSP50",$JOB,50.0214,PSS(2),1,"I")_"^"_$GET(^TMP("PSSP50",$JOB,50.0214,PSS(2),1,"E")))
- +3 SET ^TMP($JOB,LIST,+PSS(1),"AL",+PSS(2),2)=$SELECT($GET(^TMP("PSSP50",$JOB,50.0214,PSS(2),2,"I"))="":"",1:^TMP("PSSP50",$JOB,50.0214,PSS(2),2,"I")_"^"_$GET(^TMP("PSSP50",$JOB,50.0214,PSS(2),2,"E")))
- +4 SET ^TMP($JOB,LIST,+PSS(1),"AL",+PSS(2),3)=$GET(^TMP("PSSP50",$JOB,50.0214,PSS(2),3,"I"))
- +5 SET ^TMP($JOB,LIST,+PSS(1),"AL",+PSS(2),4)=$GET(^TMP("PSSP50",$JOB,50.0214,PSS(2),4,"I"))
- +6 SET ^TMP($JOB,LIST,+PSS(1),"AL",+PSS(2),5)=$GET(^TMP("PSSP50",$JOB,50.0214,PSS(2),5,"I"))
- +7 QUIT
- +8 ;
- LOOP ;
- +1 NEW PSS50DD9,PSS50D10,PSS50D11,PSS50ER9,PSS50E10,PSS50E11,PSS28OPD,PSS213PD,PSS5021X
- +2 DO FIELD^DID(50,28,"Z","POINTER","PSS50DD9","PSS50ER9")
- SET PSS28OPD=$GET(PSS50DD9("POINTER"))
- +3 DO FIELD^DID(50,213,"Z","POINTER","PSS50D10","PSS50E10")
- SET PSS213PD=$GET(PSS50D10("POINTER"))
- +4 DO FIELD^DID(50.0214,1,"Z","POINTER","PSS50D11","PSS50E11")
- SET PSS5021X=$GET(PSS50D11("POINTER"))
- +5 NEW PSSENCT
- +6 SET PSSENCT=0
- +7 SET PSS(1)=0
- FOR
- SET PSS(1)=$ORDER(^PSDRUG(PSS(1)))
- IF 'PSS(1)
- QUIT
- Begin DoDot:1
- +8 IF $PIECE($GET(^PSDRUG(PSS(1),0)),"^")=""
- QUIT
- +9 IF $GET(PSSFL)
- IF $PIECE($GET(^PSDRUG(PSS(1),"I")),"^")
- IF $PIECE($GET(^("I")),"^")'>PSSFL
- QUIT
- +10 IF $GET(PSSRTOI)=1
- IF '$PIECE($GET(^PSDRUG(PSS(1),2)),"^")
- QUIT
- +11 ;Naked reference below refers to ^PSDRUG(PSS(1),2)
- +12 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
- +13 IF $GET(PSSPK)]""
- IF 'PSSZ5
- QUIT
- +14 DO SETSUB5^PSS50AQM(PSS(1))
- +15 DO SETCMQ
- DO SETACQ
- +16 SET PSSENCT=PSSENCT+1
- End DoDot:1
- +17 SET ^TMP($JOB,LIST,0)=$SELECT($GET(PSSENCT):$GET(PSSENCT),1:"-1^NO DATA FOUND")
- +18 QUIT
- +19 ;
- SETCMQ ;
- +1 NEW PSSCMP3,PSSCMP5,PSSCMP6
- +2 SET ^TMP($JOB,LIST,+PSS(1),.01)=$PIECE(^PSDRUG(PSS(1),0),"^")
- +3 SET ^TMP($JOB,LIST,"B",$PIECE(^PSDRUG(+PSS(1),0),"^"),+PSS(1))=""
- +4 NEW PSS28OP
- SET PSS28OP=$PIECE($GET(^PSDRUG(+PSS(1),6)),"^")
- Begin DoDot:1
- +5 IF PSS28OP'=""
- IF PSS28OPD'=""
- IF PSS28OPD[(PSS28OP_":")
- SET ^TMP($JOB,LIST,+PSS(1),28)=PSS28OP_"^"_$PIECE($EXTRACT(PSS28OPD,$FIND(PSS28OPD,(PSS28OP_":")),999),";")
- QUIT
- +6 SET ^TMP($JOB,LIST,+PSS(1),28)=""
- End DoDot:1
- +7 NEW PSS213P
- SET PSS213P=$PIECE($GET(^PSDRUG(+PSS(1),3)),"^")
- Begin DoDot:1
- +8 IF PSS213P'=""
- IF PSS213PD'=""
- IF PSS213PD[(PSS213P_":")
- SET ^TMP($JOB,LIST,+PSS(1),213)=PSS213P_"^"_$PIECE($EXTRACT(PSS213PD,$FIND(PSS213PD,(PSS213P_":")),999),";")
- QUIT
- +9 SET ^TMP($JOB,LIST,+PSS(1),213)=""
- End DoDot:1
- +10 SET ^TMP($JOB,LIST,+PSS(1),215)=$PIECE($GET(^PSDRUG(+PSS(1),5)),"^")
- +11 QUIT
- +12 ;
- SETACQ ;
- +1 NEW PSS504C
- SET PSS504C=0
- +2 IF $ORDER(^PSDRUG(+PSS(1),4,0))
- NEW PSS504,PSS504ND
- Begin DoDot:1
- +3 FOR PSS504=0:0
- SET PSS504=$ORDER(^PSDRUG(+PSS(1),4,PSS504))
- IF 'PSS504
- QUIT
- Begin DoDot:2
- +4 SET PSS504ND=$GET(^PSDRUG(+PSS(1),4,PSS504,0))
- IF $PIECE(PSS504ND,"^")'=""
- SET PSS504C=PSS504C+1
- Begin DoDot:3
- +5 NEW Y
- SET (^TMP($JOB,LIST,+PSS(1),"AL",PSS504,.01),Y)=$PIECE(PSS504ND,"^")
- XECUTE ^DD("DD")
- SET ^TMP($JOB,LIST,+PSS(1),"AL",PSS504,.01)=^TMP($JOB,LIST,+PSS(1),"AL",PSS504,.01)_"^"_$GET(Y)
- +6 NEW PSS5021
- SET PSS5021=$PIECE(PSS504ND,"^",2)
- Begin DoDot:4
- +7 IF PSS5021'=""
- IF PSS5021X'=""
- IF PSS5021X[(PSS5021_":")
- SET ^TMP($JOB,LIST,+PSS(1),"AL",PSS504,1)=PSS5021_"^"_$PIECE($EXTRACT(PSS5021X,$FIND(PSS5021X,(PSS5021_":")),999),";")
- QUIT
- +8 SET ^TMP($JOB,LIST,+PSS(1),"AL",PSS504,1)=""
- End DoDot:4
- +9 NEW PSS200,PSSA200
- SET PSS200=$PIECE(PSS504ND,"^",3)
- IF PSS200
- DO GETS^DIQ(50.0214,+PSS504_","_+PSS(1),2,"E","PSSA200")
- SET ^TMP($JOB,LIST,+PSS(1),"AL",PSS504,2)=PSS200_"^"_$GET(PSSA200(50.0214,+PSS504_","_+PSS(1)_",",2,"E"))
- +10 SET ^TMP($JOB,LIST,+PSS(1),"AL",PSS504,3)=$PIECE(PSS504ND,"^",4)
- +11 SET ^TMP($JOB,LIST,+PSS(1),"AL",PSS504,4)=$PIECE(PSS504ND,"^",5)
- +12 SET ^TMP($JOB,LIST,+PSS(1),"AL",PSS504,5)=$PIECE(PSS504ND,"^",6)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +13 SET ^TMP($JOB,LIST,+PSS(1),"AL",0)=$SELECT(PSS504C:PSS504C,1:"-1^NO DATA FOUND")
- +14 QUIT
- +15
