- 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 Feb 18, 2025@23:50:40 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