PSONGR ;BHAM ISC/DMA - RETURNS INGREDIENTS LIST FOR ALLERGIES ; 11/17/92 10:21
;;7.0;OUTPATIENT PHARMACY;**11**;DEC 1997
;This routine is to be used in conjunction with the allergies package
;Input PSODA=internal entry number in file 50
;Returns PSOID=VAgeneric name pointer_"A"_VAproduct name pointer
;Returns ^TMP("PSO",$J,ifn)=primary ingredient
; where ifn=internal entry into 50.416 of primary ingredient
;Returns PSODA
;If pointers do not exist, PSOID and ^TMP("PSO",$J) are killed
;
;Other variables used - J,K and X - are NEWed before use and
;KILLed before exiting
;
K PSOID,^TMP("PSO",$J) Q:'$D(PSODA) Q:'$D(^PSDRUG(PSODA)) Q:'$D(^PSDRUG(PSODA,"ND")) S PSOID=^("ND"),PSOID=$P(PSOID,"^")_"A"_$P(PSOID,"^",3) I PSOID'?1.N1"A"1.N K PSOID Q
N J,K,X
F J=0:0 S J=$O(^PS(50.416,"APD",PSOID,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("PSO",$J,K)=$P(X,"^")
K J,K,X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSONGR 968 printed Sep 23, 2025@20:07:54 Page 2
PSONGR ;BHAM ISC/DMA - RETURNS INGREDIENTS LIST FOR ALLERGIES ; 11/17/92 10:21
+1 ;;7.0;OUTPATIENT PHARMACY;**11**;DEC 1997
+2 ;This routine is to be used in conjunction with the allergies package
+3 ;Input PSODA=internal entry number in file 50
+4 ;Returns PSOID=VAgeneric name pointer_"A"_VAproduct name pointer
+5 ;Returns ^TMP("PSO",$J,ifn)=primary ingredient
+6 ; where ifn=internal entry into 50.416 of primary ingredient
+7 ;Returns PSODA
+8 ;If pointers do not exist, PSOID and ^TMP("PSO",$J) are killed
+9 ;
+10 ;Other variables used - J,K and X - are NEWed before use and
+11 ;KILLed before exiting
+12 ;
+13 KILL PSOID,^TMP("PSO",$JOB)
if '$DATA(PSODA)
QUIT
if '$DATA(^PSDRUG(PSODA))
QUIT
if '$DATA(^PSDRUG(PSODA,"ND"))
QUIT
SET PSOID=^("ND")
SET PSOID=$PIECE(PSOID,"^")_"A"_$PIECE(PSOID,"^",3)
IF PSOID'?1.N1"A"1.N
KILL PSOID
QUIT
+14 NEW J,K,X
+15 FOR J=0:0
SET J=$ORDER(^PS(50.416,"APD",PSOID,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("PSO",$JOB,K)=$PIECE(X,"^")
+16 KILL J,K,X
+17 QUIT
