PSNNGR ;BIR/WRT-creates UTILITY GLOBAL OF INGREDIENTS FOR EACH VAPN FROM ^PSNDF(50.6, ;09/21/98 7:54
;;4.0; NATIONAL DRUG FILE;; 30 Oct 98
; This routine is to be used in conjunction of the allergies package.
; It expects an input of PSNDA=internal number in File 50.6
; Returns ^TMP("PSN",$J,IFN)=Primary Ingredient
; IFN=Internal # from 50.416 of primary ingredient
; If PSNDA doesn't exist, PSNID & ^TMP("PSN",$J) are killed
; Variables X,J,K,PSNPN are used and are killed before exiting
;
START K ^TMP("PSN",$J),PSNID D BEGIN
K PSNPN,PSNDA,J,K,X,PSNID
Q
BEGIN Q:'$D(PSNDA) Q:'$D(^PSNDF(50.6,PSNDA)) D VAPN
Q
VAPN S DA=PSNDA,X=$$VAP^PSNAPIS(DA,.LIST) I X]"" D GETLIST
Q
GETLIST F HH=0:0 S HH=$O(LIST(HH)) Q:'HH S PSNPN=HH D BLD
Q
BLD S PSNID=PSNDA_"A"_PSNPN D INGR
Q
INGR F J=0:0 S J=$O(^PS(50.416,"APD",PSNID,J)) Q:'J I $D(^PS(50.416,J,0)) S X=^(0),K=J S:$P(X,"^",2) K=$P(X,"^",2),X=^PS(50.416,K,0) S ^TMP("PSN",$J,K)=$P(X,"^",1)
K J,K,X
Q
DISPDRG K ^TMP("PSNDD",$J),PSNDD D STRT
K PSNDA,PSNVPN,PSNDD,J,K,X
Q
STRT Q:'PSNDA Q:'PSNVPN Q:'$D(^PSNDF(50.6,PSNDA)) Q:'$D(^PSNDF(50.68,PSNVPN)) S PSNDD=PSNDA_"A"_PSNVPN D FNDING
Q
FNDING F J=0:0 S J=$O(^PS(50.416,"APD",PSNDD,J)) Q:'J I $D(^PS(50.416,J,0)) S X=^(0),K=J S:$P(X,"^",2) K=$P(X,"^",2),X=^PS(50.416,K,0) S ^TMP("PSNDD",$J,K)=$P(X,"^",1)
K J,K,X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSNNGR 1366 printed Sep 23, 2025@20:00:23 Page 2
PSNNGR ;BIR/WRT-creates UTILITY GLOBAL OF INGREDIENTS FOR EACH VAPN FROM ^PSNDF(50.6, ;09/21/98 7:54
+1 ;;4.0; NATIONAL DRUG FILE;; 30 Oct 98
+2 ; This routine is to be used in conjunction of the allergies package.
+3 ; It expects an input of PSNDA=internal number in File 50.6
+4 ; Returns ^TMP("PSN",$J,IFN)=Primary Ingredient
+5 ; IFN=Internal # from 50.416 of primary ingredient
+6 ; If PSNDA doesn't exist, PSNID & ^TMP("PSN",$J) are killed
+7 ; Variables X,J,K,PSNPN are used and are killed before exiting
+8 ;
START KILL ^TMP("PSN",$JOB),PSNID
DO BEGIN
+1 KILL PSNPN,PSNDA,J,K,X,PSNID
+2 QUIT
BEGIN if '$DATA(PSNDA)
QUIT
if '$DATA(^PSNDF(50.6,PSNDA))
QUIT
DO VAPN
+1 QUIT
VAPN SET DA=PSNDA
SET X=$$VAP^PSNAPIS(DA,.LIST)
IF X]""
DO GETLIST
+1 QUIT
GETLIST FOR HH=0:0
SET HH=$ORDER(LIST(HH))
if 'HH
QUIT
SET PSNPN=HH
DO BLD
+1 QUIT
BLD SET PSNID=PSNDA_"A"_PSNPN
DO INGR
+1 QUIT
INGR FOR J=0:0
SET J=$ORDER(^PS(50.416,"APD",PSNID,J))
if 'J
QUIT
IF $DATA(^PS(50.416,J,0))
SET X=^(0)
SET K=J
if $PIECE(X,"^",2)
SET K=$PIECE(X,"^",2)
SET X=^PS(50.416,K,0)
SET ^TMP("PSN",$JOB,K)=$PIECE(X,"^",1)
+1 KILL J,K,X
+2 QUIT
DISPDRG KILL ^TMP("PSNDD",$JOB),PSNDD
DO STRT
+1 KILL PSNDA,PSNVPN,PSNDD,J,K,X
+2 QUIT
STRT if 'PSNDA
QUIT
if 'PSNVPN
QUIT
if '$DATA(^PSNDF(50.6,PSNDA))
QUIT
if '$DATA(^PSNDF(50.68,PSNVPN))
QUIT
SET PSNDD=PSNDA_"A"_PSNVPN
DO FNDING
+1 QUIT
FNDING FOR J=0:0
SET J=$ORDER(^PS(50.416,"APD",PSNDD,J))
if 'J
QUIT
IF $DATA(^PS(50.416,J,0))
SET X=^(0)
SET K=J
if $PIECE(X,"^",2)
SET K=$PIECE(X,"^",2)
SET X=^PS(50.416,K,0)
SET ^TMP("PSNDD",$JOB,K)=$PIECE(X,"^",1)
+1 KILL J,K,X
+2 QUIT
