PSS50F ;BIR/LDT - API FOR INFORMATION FROM FILE 50; 5 Sep 03
;;1.0;PHARMACY DATA MANAGEMENT;**85,91**;9/30/97
;External reference to DD(50,0,"IX" supported by DBIA 4323
;External reference to PRC(441 is supported by DBIA 214
;
OLDNM ;
;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,CNT
I $G(LIST)']"" Q
K ^TMP($J,LIST)
I +$G(PSSIEN)'>0,($G(PSSFT)']"") S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
I $G(PSSIEN)]"",+$G(PSSIEN)'>0 S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
S SCR("S")="",CNT=0
I +$G(PSSFL)>0!($G(PSSPK)]"") N PSS5ND,PSSZ3,PSSZ4 D SETSCRN^PSS50A
I $G(PSSIEN)]"" N PSSIEN2 S PSSIEN2=$$FIND1^DIC(50,"","A","`"_PSSIEN,,SCR("S"),"") D
.I +PSSIEN2'>0 S ^TMP($J,LIST,0)=-1_"^"_"NO DATA FOUND" Q
.S ^TMP($J,LIST,0)=1
.K ^TMP($J,"PSS50") D GETS^DIQ(50,+PSSIEN2,".01;900*","IE","^TMP($J,""PSS50""") 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)=^TMP($J,"PSS50",50,PSS(1),.01,"I")
..S ^TMP($J,LIST,"B",^TMP($J,"PSS50",50,PSS(1),.01,"I"),+PSS(1))=""
..S PSS(2)=0 F S PSS(2)=$O(^TMP($J,"PSS50",50.01,PSS(2))) Q:'PSS(2) D SETOLDNM S CNT=CNT+1
..S ^TMP($J,LIST,+PSS(1),"OLD",0)=$S(CNT>0:CNT,1:"-1^NO DATA FOUND")
I +$G(PSSIEN)'>0,$G(PSSFT)]"" D
.I PSSFT["??" D LOOP(1) Q
.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) K ^TMP($J,"PSS50") S CNT=0 D GETS^DIQ(50,+PSSIEN,".01;900*","IE","^TMP($J,""PSS50""") 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)=^TMP($J,"PSS50",50,PSS(1),.01,"I")
...S ^TMP($J,LIST,"B",^TMP($J,"PSS50",50,PSS(1),.01,"I"),+PSS(1))=""
...S PSS(2)=0 F S PSS(2)=$O(^TMP($J,"PSS50",50.01,PSS(2))) Q:'PSS(2) D SETOLDNM S CNT=CNT+1
...S ^TMP($J,LIST,+PSS(1),"OLD",0)=$S(CNT>0:CNT,1:"-1^NO DATA FOUND")
K ^TMP("DILIST",$J),^TMP($J,"PSS50")
Q
;
LOOP(PSS) ;
N CNT,PSSIEN S CNT=0
S PSSIEN=0 F S PSSIEN=$O(^PSDRUG(PSSIEN)) Q:'PSSIEN D
.I $P($G(^PSDRUG(PSSIEN,0)),"^")="" Q
.I $G(PSSFL),$P($G(^PSDRUG(PSSIEN,"I")),"^"),$P($G(^("I")),"^")'>PSSFL Q
.I $G(PSSRTOI)=1,'$P($G(^PSDRUG(PSSIEN,2)),"^") Q
.;Naked reference below refers to ^PSDRUG(PSSIEN,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 @PSS
S ^TMP($J,LIST,0)=$S(CNT>0:CNT,1:"-1^NO DATA FOUND")
Q
;
SETOLDNM ;
S ^TMP($J,LIST,+PSS(1),"OLD",+PSS(2),.01)=^TMP($J,"PSS50",50.01,PSS(2),.01,"I")
S ^TMP($J,LIST,+PSS(1),"OLD",+PSS(2),.02)=$S($G(^TMP($J,"PSS50",50.01,PSS(2),.02,"I"))="":"",1:^TMP($J,"PSS50",50.01,PSS(2),.02,"I")_"^"_^TMP($J,"PSS50",50.01,PSS(2),.02,"E"))
Q
;
SETLIST ;
S ^TMP($J,LIST,+PSS(1),.01)=^TMP($J,"PSS50",50,PSS(1),.01,"I")
S ^TMP($J,LIST,$S($G(PSSD)]"":$P(PSSD,"^"),1:"B"),^TMP($J,"PSS50",50,PSS(1),.01,"I"),+PSS(1))=""
S ^TMP($J,LIST,+PSS(1),2.1)=$S($G(^TMP($J,"PSS50",50,PSS(1),2.1,"I"))="":"",1:^TMP($J,"PSS50",50,PSS(1),2.1,"I")_"^"_^TMP($J,"PSS50",50,PSS(1),2.1,"E"))
S ^TMP($J,LIST,+PSS(1),100)=$S($G(^TMP($J,"PSS50",50,PSS(1),100,"I"))="":"",1:^TMP($J,"PSS50",50,PSS(1),100,"I")_"^"_^TMP($J,"PSS50",50,PSS(1),100,"E"))
Q
;
SETLOOK ;
S ^TMP($J,LIST,+PSS(2),.01)=PSS50(50,PSS(2),.01,"I")
S ^TMP($J,LIST,$S($G(PSSCRFL)]"":$P(PSSCRFL,"^"),1:"B"),PSS50(50,PSS(2),.01,"I"),+PSS(2))=""
S ^TMP($J,LIST,+PSS(2),2.1)=$S($G(PSS50(50,PSS(2),25,"I"))="":"",1:PSS50(50,PSS(2),25,"I")_"^"_PSS50(50,PSS(2),25,"E"))
S ^TMP($J,LIST,+PSS(2),100)=$S($G(PSS50(50,PSS(2),100,"I"))="":"",1:PSS50(50,PSS(2),100,"I")_"^"_PSS50(50,PSS(2),100,"E"))
S ^TMP($J,LIST,+PSS(2),101)=$S($G(PSS50(50,PSS(2),101,"I"))="":"",1:PSS50(50,PSS(2),101,"I")_"^"_PSS50(50,PSS(2),101,"E"))
Q
;
ADDOLDNM(PSSIEN2,PSSONM2,PSSDT2) ;
;PSSIEN2 - IEN of entry in DRUG file (#50).
;PSSONM2 - Text of the old name.
;PSSDT2 - Date changed in FileMan format.
;0 (zero)is returned if ADD was unsuccessful. 1 (one) will indicate successful ADD.
;Adding new entry to OLD NAME multiple (#50.01) of the DRUG file (#50).
I (+$G(PSSIEN2)'>0)!($G(PSSONM2)']"") Q 0
S:+$G(PSSDT2)'>0 PSSDT2=DT
N PSS,QFLG
N PSSIEN4 S PSSIEN4=$$FIND1^DIC(50,"","A","`"_PSSIEN2,,,"")
I +PSSIEN4'>0 Q 0
D LIST^DIC(50.01,","_PSSIEN2_",","@;.01IE;.02IE","P",,,,,,,)
I +^TMP("DILIST",$J,0)'>0 D
.S PSS(1,50.01,"+2,"_PSSIEN2_",",.01)=$G(PSSONM2)
.S PSS(1,50.01,"+2,"_PSSIEN2_",",.02)=$G(PSSDT2)
I +^TMP("DILIST",$J,0)>0 S (QFLG,PSS)=0 F S PSS=$O(^TMP("DILIST",$J,PSS)) Q:'PSS Q:QFLG D
.I $P($G(^TMP("DILIST",$J,PSS,0)),"^",2)=PSSONM2,($P($G(^(0)),"^",4)=PSSDT2) S QFLG=1 Q
.S PSS(1,50.01,"+2,"_PSSIEN2_",",.01)=$G(PSSONM2)
.S PSS(1,50.01,"+2,"_PSSIEN2_",",.02)=$G(PSSDT2)
I $G(QFLG) Q 0
D UPDATE^DIE("","PSS(1)") Q 1
Q
EDTIFCAP(PSSIEN2,PSSVAL2) ;
;PSSIEN2 - IEN of entry in DRUG file (#50).
;PSSVAL2 - IFCAP ITEM NUMBER to be added.
;0 (zero)is returned if ADD was unsuccessful. 1 (one) will indicate successful ADD.
;Adding new entry to IFCAP ITEM NUMBER multiple (#50.01) of the DRUG file (#50).
I (+$G(PSSIEN2)'>0)!+($G(PSSVAL2)'>0) Q 0
N PSS,QFLG
N PSSIEN3 S PSSIEN3=$$FIND1^DIC(441,"","A","`"_PSSVAL2,,,"")
I +PSSIEN3'>0 Q 0
N PSSIEN4 S PSSIEN4=$$FIND1^DIC(50,"","A","`"_PSSIEN2,,,"")
I +PSSIEN4'>0 Q 0
D LIST^DIC(50.0441,","_PSSIEN2_",","@;.01IE","P",,,,,,,)
I +^TMP("DILIST",$J,0)'>0 D
.S PSS(1,50.0441,"+2,"_PSSIEN2_",",.01)=$G(PSSVAL2)
I +^TMP("DILIST",$J,0)>0 S (QFLG,PSS)=0 F S PSS=$O(^TMP("DILIST",$J,PSS)) Q:'PSS Q:QFLG D
.I $P($G(^TMP("DILIST",$J,PSS,0)),"^",2)=PSSVAL2 S QFLG=1 Q
.I $O(^PSDRUG("AB",PSSVAL2,"")) S QFLG=1 Q
.S PSS(1,50.0441,"+2,"_PSSIEN2_",",.01)=$G(PSSVAL2)
I $G(QFLG) Q 0
D UPDATE^DIE("","PSS(1)") Q 1
Q
1 ;
N CNT2 S CNT2=0
K ^TMP($J,"PSS50") D GETS^DIQ(50,+PSSIEN,".01;900*","IE","^TMP($J,""PSS50""") 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)=^TMP($J,"PSS50",50,PSS(1),.01,"I"),CNT=CNT+1
.S ^TMP($J,LIST,"B",^TMP($J,"PSS50",50,PSS(1),.01,"I"),+PSS(1))=""
.S (PSS(2),CNT2)=0 F S PSS(2)=$O(^TMP($J,"PSS50",50.01,PSS(2))) Q:'PSS(2) D SETOLDNM S CNT2=CNT2+1
.S ^TMP($J,LIST,+PSS(1),"OLD",0)=$S(CNT2>0:CNT2,1:"-1^NO DATA FOUND")
K ^TMP($J,"PSS50")
Q
2 ;
K ^TMP($J,"PSS50") D GETS^DIQ(50,+PSSIEN,".01;100;2.1","IE","^TMP($J,""PSS50""") S PSS(1)=0
F S PSS(1)=$O(^TMP($J,"PSS50",50,PSS(1))) Q:'PSS(1) D SETLIST S CNT=CNT+1
K ^TMP($J,"PSS50")
Q
PARSE(PSSLUP) ; Create array of cross references, piece 2 of the array =1 for pointer fields, else 0
I $G(PSSLUP)="" Q
N PSSLUPA,PSSLUP1,PSSLUP2,PSSLUP3,PSSLUP4,PSSLUP5,PSSDTYPE,PSSPTER
I $E(PSSLUP)="^" S PSSLUP=$E(PSSLUP,2,$L(PSSLUP))
S PSSLUP1=0 F PSSLUP2=1:1:$L(PSSLUP) I $E(PSSLUP,PSSLUP2)="^" S PSSLUP1=PSSLUP1+1
S PSSLUP1=PSSLUP1+1
S PSSLUP4=1 F PSSLUP3=1:1:PSSLUP1 S PSSLUP5=$P(PSSLUP,"^",PSSLUP3) I PSSLUP5'="" D S PSSLUPAR(PSSLUP4)=PSSLUP5_"^"_$G(PSSPTER),PSSLUP4=PSSLUP4+1
.N PSSCRX,PSSCRX1 S PSSPTER=0
.S PSSCRX="" F S PSSCRX=$O(^DD(50,0,"IX",PSSLUP5,PSSCRX)) Q:PSSCRX="" S PSSCRX1="" F S PSSCRX1=$O(^DD(50,0,"IX",PSSLUP5,PSSCRX,PSSCRX1)) Q:PSSCRX1="" D
..K PSSDTYPE D FIELD^DID(PSSCRX,PSSCRX1,,"TYPE","PSSDTYPE") I $G(PSSDTYPE("TYPE"))="POINTER" S PSSPTER=1
Q
PSS50F ;BIR/LDT - API FOR INFORMATION FROM FILE 50; 5 Sep 03
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**85,91**;9/30/97
+2 ;External reference to DD(50,0,"IX" supported by DBIA 4323
+3 ;External reference to PRC(441 is supported by DBIA 214
+4 ;
OLDNM ;
+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,CNT
+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 IF $GET(PSSIEN)]""
IF +$GET(PSSIEN)'>0
SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
QUIT
+15 SET SCR("S")=""
SET CNT=0
+16 IF +$GET(PSSFL)>0!($GET(PSSPK)]"")
NEW PSS5ND,PSSZ3,PSSZ4
DO SETSCRN^PSS50A
+17 IF $GET(PSSIEN)]""
NEW PSSIEN2
SET PSSIEN2=$$FIND1^DIC(50,"","A","`"_PSSIEN,,SCR("S"),"")
Begin DoDot:1
+18 IF +PSSIEN2'>0
SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
QUIT
+19 SET ^TMP($JOB,LIST,0)=1
+20 KILL ^TMP($JOB,"PSS50")
DO GETS^DIQ(50,+PSSIEN2,".01;900*","IE","^TMP($J,""PSS50""")
SET PSS(1)=0
+21 FOR
SET PSS(1)=$ORDER(^TMP($JOB,"PSS50",50,PSS(1)))
IF 'PSS(1)
QUIT
Begin DoDot:2
+22 SET ^TMP($JOB,LIST,+PSS(1),.01)=^TMP($JOB,"PSS50",50,PSS(1),.01,"I")
+23 SET ^TMP($JOB,LIST,"B",^TMP($JOB,"PSS50",50,PSS(1),.01,"I"),+PSS(1))=""
+24 SET PSS(2)=0
FOR
SET PSS(2)=$ORDER(^TMP($JOB,"PSS50",50.01,PSS(2)))
IF 'PSS(2)
QUIT
DO SETOLDNM
SET CNT=CNT+1
+25 SET ^TMP($JOB,LIST,+PSS(1),"OLD",0)=$SELECT(CNT>0:CNT,1:"-1^NO DATA FOUND")
End DoDot:2
End DoDot:1
+26 IF +$GET(PSSIEN)'>0
IF $GET(PSSFT)]""
Begin DoDot:1
+27 IF PSSFT["??"
DO LOOP(1)
QUIT
+28 DO FIND^DIC(50,,"@;.01","QP",PSSFT,,"B",SCR("S"),,"")
+29 IF +$GET(^TMP("DILIST",$JOB,0))=0
SET ^TMP($JOB,LIST,0)=-1_"^"_"NO DATA FOUND"
QUIT
+30 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
+31 SET PSSIEN=+^TMP("DILIST",$JOB,PSSXX,0)
KILL ^TMP($JOB,"PSS50")
SET CNT=0
DO GETS^DIQ(50,+PSSIEN,".01;900*","IE","^TMP($J,""PSS50""")
SET PSS(1)=0
+32 FOR
SET PSS(1)=$ORDER(^TMP($JOB,"PSS50",50,PSS(1)))
IF 'PSS(1)
QUIT
Begin DoDot:3
+33 SET ^TMP($JOB,LIST,+PSS(1),.01)=^TMP($JOB,"PSS50",50,PSS(1),.01,"I")
+34 SET ^TMP($JOB,LIST,"B",^TMP($JOB,"PSS50",50,PSS(1),.01,"I"),+PSS(1))=""
+35 SET PSS(2)=0
FOR
SET PSS(2)=$ORDER(^TMP($JOB,"PSS50",50.01,PSS(2)))
IF 'PSS(2)
QUIT
DO SETOLDNM
SET CNT=CNT+1
+36 SET ^TMP($JOB,LIST,+PSS(1),"OLD",0)=$SELECT(CNT>0:CNT,1:"-1^NO DATA FOUND")
End DoDot:3
End DoDot:2
End DoDot:1
+37 KILL ^TMP("DILIST",$JOB),^TMP($JOB,"PSS50")
+38 QUIT
+39 ;
LOOP(PSS) ;
+1 NEW CNT,PSSIEN
SET CNT=0
+2 SET PSSIEN=0
FOR
SET PSSIEN=$ORDER(^PSDRUG(PSSIEN))
IF 'PSSIEN
QUIT
Begin DoDot:1
+3 IF $PIECE($GET(^PSDRUG(PSSIEN,0)),"^")=""
QUIT
+4 IF $GET(PSSFL)
IF $PIECE($GET(^PSDRUG(PSSIEN,"I")),"^")
IF $PIECE($GET(^("I")),"^")'>PSSFL
QUIT
+5 IF $GET(PSSRTOI)=1
IF '$PIECE($GET(^PSDRUG(PSSIEN,2)),"^")
QUIT
+6 ;Naked reference below refers to ^PSDRUG(PSSIEN,2)
+7 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
+8 IF $GET(PSSPK)]""
IF 'PSSZ5
QUIT
+9 DO @PSS
End DoDot:1
+10 SET ^TMP($JOB,LIST,0)=$SELECT(CNT>0:CNT,1:"-1^NO DATA FOUND")
+11 QUIT
+12 ;
SETOLDNM ;
+1 SET ^TMP($JOB,LIST,+PSS(1),"OLD",+PSS(2),.01)=^TMP($JOB,"PSS50",50.01,PSS(2),.01,"I")
+2 SET ^TMP($JOB,LIST,+PSS(1),"OLD",+PSS(2),.02)=$SELECT($GET(^TMP($JOB,"PSS50",50.01,PSS(2),.02,"I"))="":"",1:^TMP($JOB,"PSS50",50.01,PSS(2),.02,"I")_"^"_^TMP($JOB,"PSS50",50.01,PSS(2),.02,"E"))
+3 QUIT
+4 ;
SETLIST ;
+1 SET ^TMP($JOB,LIST,+PSS(1),.01)=^TMP($JOB,"PSS50",50,PSS(1),.01,"I")
+2 SET ^TMP($JOB,LIST,$SELECT($GET(PSSD)]"":$PIECE(PSSD,"^"),1:"B"),^TMP($JOB,"PSS50",50,PSS(1),.01,"I"),+PSS(1))=""
+3 SET ^TMP($JOB,LIST,+PSS(1),2.1)=$SELECT($GET(^TMP($JOB,"PSS50",50,PSS(1),2.1,"I"))="":"",1:^TMP($JOB,"PSS50",50,PSS(1),2.1,"I")_"^"_^TMP($JOB,"PSS50",50,PSS(1),2.1,"E"))
+4 SET ^TMP($JOB,LIST,+PSS(1),100)=$SELECT($GET(^TMP($JOB,"PSS50",50,PSS(1),100,"I"))="":"",1:^TMP($JOB,"PSS50",50,PSS(1),100,"I")_"^"_^TMP($JOB,"PSS50",50,PSS(1),100,"E"))
+5 QUIT
+6 ;
SETLOOK ;
+1 SET ^TMP($JOB,LIST,+PSS(2),.01)=PSS50(50,PSS(2),.01,"I")
+2 SET ^TMP($JOB,LIST,$SELECT($GET(PSSCRFL)]"":$PIECE(PSSCRFL,"^"),1:"B"),PSS50(50,PSS(2),.01,"I"),+PSS(2))=""
+3 SET ^TMP($JOB,LIST,+PSS(2),2.1)=$SELECT($GET(PSS50(50,PSS(2),25,"I"))="":"",1:PSS50(50,PSS(2),25,"I")_"^"_PSS50(50,PSS(2),25,"E"))
+4 SET ^TMP($JOB,LIST,+PSS(2),100)=$SELECT($GET(PSS50(50,PSS(2),100,"I"))="":"",1:PSS50(50,PSS(2),100,"I")_"^"_PSS50(50,PSS(2),100,"E"))
+5 SET ^TMP($JOB,LIST,+PSS(2),101)=$SELECT($GET(PSS50(50,PSS(2),101,"I"))="":"",1:PSS50(50,PSS(2),101,"I")_"^"_PSS50(50,PSS(2),101,"E"))
+6 QUIT
+7 ;
ADDOLDNM(PSSIEN2,PSSONM2,PSSDT2) ;
+1 ;PSSIEN2 - IEN of entry in DRUG file (#50).
+2 ;PSSONM2 - Text of the old name.
+3 ;PSSDT2 - Date changed in FileMan format.
+4 ;0 (zero)is returned if ADD was unsuccessful. 1 (one) will indicate successful ADD.
+5 ;Adding new entry to OLD NAME multiple (#50.01) of the DRUG file (#50).
+6 IF (+$GET(PSSIEN2)'>0)!($GET(PSSONM2)']"")
QUIT 0
+7 IF +$GET(PSSDT2)'>0
SET PSSDT2=DT
+8 NEW PSS,QFLG
+9 NEW PSSIEN4
SET PSSIEN4=$$FIND1^DIC(50,"","A","`"_PSSIEN2,,,"")
+10 IF +PSSIEN4'>0
QUIT 0
+11 DO LIST^DIC(50.01,","_PSSIEN2_",","@;.01IE;.02IE","P",,,,,,,)
+12 IF +^TMP("DILIST",$JOB,0)'>0
Begin DoDot:1
+13 SET PSS(1,50.01,"+2,"_PSSIEN2_",",.01)=$GET(PSSONM2)
+14 SET PSS(1,50.01,"+2,"_PSSIEN2_",",.02)=$GET(PSSDT2)
End DoDot:1
+15 IF +^TMP("DILIST",$JOB,0)>0
SET (QFLG,PSS)=0
FOR
SET PSS=$ORDER(^TMP("DILIST",$JOB,PSS))
IF 'PSS
QUIT
IF QFLG
QUIT
Begin DoDot:1
+16 IF $PIECE($GET(^TMP("DILIST",$JOB,PSS,0)),"^",2)=PSSONM2
IF ($PIECE($GET(^(0)),"^",4)=PSSDT2)
SET QFLG=1
QUIT
+17 SET PSS(1,50.01,"+2,"_PSSIEN2_",",.01)=$GET(PSSONM2)
+18 SET PSS(1,50.01,"+2,"_PSSIEN2_",",.02)=$GET(PSSDT2)
End DoDot:1
+19 IF $GET(QFLG)
QUIT 0
+20 DO UPDATE^DIE("","PSS(1)")
QUIT 1
+21 QUIT
EDTIFCAP(PSSIEN2,PSSVAL2) ;
+1 ;PSSIEN2 - IEN of entry in DRUG file (#50).
+2 ;PSSVAL2 - IFCAP ITEM NUMBER to be added.
+3 ;0 (zero)is returned if ADD was unsuccessful. 1 (one) will indicate successful ADD.
+4 ;Adding new entry to IFCAP ITEM NUMBER multiple (#50.01) of the DRUG file (#50).
+5 IF (+$GET(PSSIEN2)'>0)!+($GET(PSSVAL2)'>0)
QUIT 0
+6 NEW PSS,QFLG
+7 NEW PSSIEN3
SET PSSIEN3=$$FIND1^DIC(441,"","A","`"_PSSVAL2,,,"")
+8 IF +PSSIEN3'>0
QUIT 0
+9 NEW PSSIEN4
SET PSSIEN4=$$FIND1^DIC(50,"","A","`"_PSSIEN2,,,"")
+10 IF +PSSIEN4'>0
QUIT 0
+11 DO LIST^DIC(50.0441,","_PSSIEN2_",","@;.01IE","P",,,,,,,)
+12 IF +^TMP("DILIST",$JOB,0)'>0
Begin DoDot:1
+13 SET PSS(1,50.0441,"+2,"_PSSIEN2_",",.01)=$GET(PSSVAL2)
End DoDot:1
+14 IF +^TMP("DILIST",$JOB,0)>0
SET (QFLG,PSS)=0
FOR
SET PSS=$ORDER(^TMP("DILIST",$JOB,PSS))
IF 'PSS
QUIT
IF QFLG
QUIT
Begin DoDot:1
+15 IF $PIECE($GET(^TMP("DILIST",$JOB,PSS,0)),"^",2)=PSSVAL2
SET QFLG=1
QUIT
+16 IF $ORDER(^PSDRUG("AB",PSSVAL2,""))
SET QFLG=1
QUIT
+17 SET PSS(1,50.0441,"+2,"_PSSIEN2_",",.01)=$GET(PSSVAL2)
End DoDot:1
+18 IF $GET(QFLG)
QUIT 0
+19 DO UPDATE^DIE("","PSS(1)")
QUIT 1
+20 QUIT
1 ;
+1 NEW CNT2
SET CNT2=0
+2 KILL ^TMP($JOB,"PSS50")
DO GETS^DIQ(50,+PSSIEN,".01;900*","IE","^TMP($J,""PSS50""")
SET PSS(1)=0
+3 FOR
SET PSS(1)=$ORDER(^TMP($JOB,"PSS50",50,PSS(1)))
IF 'PSS(1)
QUIT
Begin DoDot:1
+4 SET ^TMP($JOB,LIST,+PSS(1),.01)=^TMP($JOB,"PSS50",50,PSS(1),.01,"I")
SET CNT=CNT+1
+5 SET ^TMP($JOB,LIST,"B",^TMP($JOB,"PSS50",50,PSS(1),.01,"I"),+PSS(1))=""
+6 SET (PSS(2),CNT2)=0
FOR
SET PSS(2)=$ORDER(^TMP($JOB,"PSS50",50.01,PSS(2)))
IF 'PSS(2)
QUIT
DO SETOLDNM
SET CNT2=CNT2+1
+7 SET ^TMP($JOB,LIST,+PSS(1),"OLD",0)=$SELECT(CNT2>0:CNT2,1:"-1^NO DATA FOUND")
End DoDot:1
+8 KILL ^TMP($JOB,"PSS50")
+9 QUIT
2 ;
+1 KILL ^TMP($JOB,"PSS50")
DO GETS^DIQ(50,+PSSIEN,".01;100;2.1","IE","^TMP($J,""PSS50""")
SET PSS(1)=0
+2 FOR
SET PSS(1)=$ORDER(^TMP($JOB,"PSS50",50,PSS(1)))
IF 'PSS(1)
QUIT
DO SETLIST
SET CNT=CNT+1
+3 KILL ^TMP($JOB,"PSS50")
+4 QUIT
PARSE(PSSLUP) ; Create array of cross references, piece 2 of the array =1 for pointer fields, else 0
+1 IF $GET(PSSLUP)=""
QUIT
+2 NEW PSSLUPA,PSSLUP1,PSSLUP2,PSSLUP3,PSSLUP4,PSSLUP5,PSSDTYPE,PSSPTER
+3 IF $EXTRACT(PSSLUP)="^"
SET PSSLUP=$EXTRACT(PSSLUP,2,$LENGTH(PSSLUP))
+4 SET PSSLUP1=0
FOR PSSLUP2=1:1:$LENGTH(PSSLUP)
IF $EXTRACT(PSSLUP,PSSLUP2)="^"
SET PSSLUP1=PSSLUP1+1
+5 SET PSSLUP1=PSSLUP1+1
+6 SET PSSLUP4=1
FOR PSSLUP3=1:1:PSSLUP1
SET PSSLUP5=$PIECE(PSSLUP,"^",PSSLUP3)
IF PSSLUP5'=""
Begin DoDot:1
+7 NEW PSSCRX,PSSCRX1
SET PSSPTER=0
+8 SET PSSCRX=""
FOR
SET PSSCRX=$ORDER(^DD(50,0,"IX",PSSLUP5,PSSCRX))
IF PSSCRX=""
QUIT
SET PSSCRX1=""
FOR
SET PSSCRX1=$ORDER(^DD(50,0,"IX",PSSLUP5,PSSCRX,PSSCRX1))
IF PSSCRX1=""
QUIT
Begin DoDot:2
+9 KILL PSSDTYPE
DO FIELD^DID(PSSCRX,PSSCRX1,,"TYPE","PSSDTYPE")
IF $GET(PSSDTYPE("TYPE"))="POINTER"
SET PSSPTER=1
End DoDot:2
End DoDot:1
SET PSSLUPAR(PSSLUP4)=PSSLUP5_"^"_$GET(PSSPTER)
SET PSSLUP4=PSSLUP4+1
+10 QUIT
