PSN110P ;BIR/DMA-check APD cross references in files 50.416 and 56 ; 24 Oct 2006 12:56 PM
;;4.0; NATIONAL DRUG FILE;**110**; 30 Oct 98;Build 4
;
N DA,DIC,DIE,DINUM,DR,ID,ING,INT,INT1,K,K1,PSN,PSNID,X,X1,X2
S DA=0 F S DA=$O(^PS(50.416,DA)),ID="" Q:'DA F S ID=$O(^PS(50.416,DA,1,"B",ID)),K=0 Q:ID="" F S K=$O(^PS(50.416,DA,1,"B",ID,K)) Q:'K I '$D(^PSNDF(50.68,$P(ID,"A",2),2,DA)) D
.K ^PS(50.416,DA,1,"B",ID,K),^PS(50.416,DA,1,K),^PS(50.416,"APD",ID,DA) S X="^PS(56,""APD"","""_ID_""")" F S X=$Q(@X) Q:$QS(X,3)'=ID D
..S INT=^PS(56,$QS(X,5),0) I $P(INT,"^",2)=DA!($P(INT,"^",3)=DA) K @X,^PS(56,"APD",$QS(X,4),$QS(X,3),$QS(X,5)),^PS(56,"AI1",DA,$QS(X,5)),^PS(56,"AI2",DA,$QS(X,5))
;
K ^TMP($J) M ^TMP($J)=@XPDGREF@("ING") K ^TMP("PSN",$J) M ^TMP("PSN",$J)=@XPDGREF@("PRI")
S DA=0 F S DA=$O(^PSNDF(50.68,DA)),K=0 Q:'DA F S K=$O(^PSNDF(50.68,DA,2,K)) Q:'K I $D(^TMP($J,DA,K)) S PSNID=$P(^PSNDF(50.68,DA,0),"^",2)_"A"_DA K ^PSNDF(50.68,DA,2,K) D
.S K1=0 F S K1=$O(^PS(50.416,K,1,"B",PSNID,K1)) Q:'K1 K ^(K1),^PS(50.416,K,1,K1),^PS(50.416,"APD",PSNID,K) S X="^PS(56,""APD"","""_PSNID_""")" F S X=$Q(@X) Q:$QS(X,3)'=PSNID D
..S INT=^PS(56,$QS(X,5),0) I $P(INT,"^",2)=K!($P(INT,"^",3))=K K @X,^PS(56,"APD",$QS(X,4),$QS(X,3),$QS(X,5)),^PS(56,"AI1",K,$QS(X,5)),^PS(56,"AI2",K,$QS(X,5))
S X="^TMP(""PSN"",$J)" F S X=$Q(@X) Q:X'[("^TMP(""PSN"","_$J) S PSN=$QS(X,3),ING=$QS(X,4),PSN=$P(^PSNDF(50.68,PSN,0),"^",2)_"A"_PSN D
.S X1="^PS(56,""APD"","""_PSN_""")" F S X1=$Q(@X1) Q:$QS(X1,3)'=PSN S INT=$QS(X1,5),INT1=^PS(56,INT,0) I $P(INT1,"^",2)=ING!($P(INT1,"^",3)=ING) D
..K ^PS(56,"AI1",ING,INT),^PS(56,"AI2",ING,INT)
..K @X1,^PS(56,"APD",$QS(X1,4),$QS(X1,3),$QS(X1,5))
..S X2="^PS(56,""AE"")" F S X2=$Q(@X2) Q:$QS(X2,3)'=ING I $QS(X2,5)=INT K @X2 K ^PS(56,"AE",$QS(X2,4),$QS(X2,3),$QS(X2,5))
;
;ADD INGREDIENT TO CLONIDINE HCL 0.1MG TAB,UD
S DA=444,DA(1)=13554,DIC="^PSNDF(50.68,"_DA(1)_",2,",DIC(0)="L",X=DA,DINUM=X D FILE^DICN S DIE=DIC,DR="1////0.1;2////20;" D ^DIE
K DA,DIC,DIE,DINUM,DR,ID,ING,INT,INT1,K,K1,PSN,PSNID,X,X1,X2,^TMP($J),^TMP("PSN",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSN110P 2109 printed Sep 23, 2025@19:52:29 Page 2
PSN110P ;BIR/DMA-check APD cross references in files 50.416 and 56 ; 24 Oct 2006 12:56 PM
+1 ;;4.0; NATIONAL DRUG FILE;**110**; 30 Oct 98;Build 4
+2 ;
+3 NEW DA,DIC,DIE,DINUM,DR,ID,ING,INT,INT1,K,K1,PSN,PSNID,X,X1,X2
+4 SET DA=0
FOR
SET DA=$ORDER(^PS(50.416,DA))
SET ID=""
if 'DA
QUIT
FOR
SET ID=$ORDER(^PS(50.416,DA,1,"B",ID))
SET K=0
if ID=""
QUIT
FOR
SET K=$ORDER(^PS(50.416,DA,1,"B",ID,K))
if 'K
QUIT
IF '$DATA(^PSNDF(50.68,$PIECE(ID,"A",2),2,DA))
Begin DoDot:1
+5 KILL ^PS(50.416,DA,1,"B",ID,K),^PS(50.416,DA,1,K),^PS(50.416,"APD",ID,DA)
SET X="^PS(56,""APD"","""_ID_""")"
FOR
SET X=$QUERY(@X)
if $QSUBSCRIPT(X,3)'=ID
QUIT
Begin DoDot:2
+6 SET INT=^PS(56,$QSUBSCRIPT(X,5),0)
IF $PIECE(INT,"^",2)=DA!($PIECE(INT,"^",3)=DA)
KILL @X,^PS(56,"APD",$QSUBSCRIPT(X,4),$QSUBSCRIPT(X,3),$QSUBSCRIPT(X,5)),^PS(56,"AI1",DA,$QSUBSCRIPT(X,5)),^PS(56,"AI2",DA,$QSUBSCRIPT(X,5))
End DoDot:2
End DoDot:1
+7 ;
+8 KILL ^TMP($JOB)
MERGE ^TMP($JOB)=@XPDGREF@("ING")
KILL ^TMP("PSN",$JOB)
MERGE ^TMP("PSN",$JOB)=@XPDGREF@("PRI")
+9 SET DA=0
FOR
SET DA=$ORDER(^PSNDF(50.68,DA))
SET K=0
if 'DA
QUIT
FOR
SET K=$ORDER(^PSNDF(50.68,DA,2,K))
if 'K
QUIT
IF $DATA(^TMP($JOB,DA,K))
SET PSNID=$PIECE(^PSNDF(50.68,DA,0),"^",2)_"A"_DA
KILL ^PSNDF(50.68,DA,2,K)
Begin DoDot:1
+10 SET K1=0
FOR
SET K1=$ORDER(^PS(50.416,K,1,"B",PSNID,K1))
if 'K1
QUIT
KILL ^(K1),^PS(50.416,K,1,K1),^PS(50.416,"APD",PSNID,K)
SET X="^PS(56,""APD"","""_PSNID_""")"
FOR
SET X=$QUERY(@X)
if $QSUBSCRIPT(X,3)'=PSNID
QUIT
Begin DoDot:2
+11 SET INT=^PS(56,$QSUBSCRIPT(X,5),0)
IF $PIECE(INT,"^",2)=K!($PIECE(INT,"^",3))=K
KILL @X,^PS(56,"APD",$QSUBSCRIPT(X,4),$QSUBSCRIPT(X,3),$QSUBSCRIPT(X,5)),^PS(56,"AI1",K,$QSUBSCRIPT(X,5)),^PS(56,"AI2",K,$QSUBSCRIPT(X,5))
End DoDot:2
End DoDot:1
+12 SET X="^TMP(""PSN"",$J)"
FOR
SET X=$QUERY(@X)
if X'[("^TMP(""PSN"","_$JOB)
QUIT
SET PSN=$QSUBSCRIPT(X,3)
SET ING=$QSUBSCRIPT(X,4)
SET PSN=$PIECE(^PSNDF(50.68,PSN,0),"^",2)_"A"_PSN
Begin DoDot:1
+13 SET X1="^PS(56,""APD"","""_PSN_""")"
FOR
SET X1=$QUERY(@X1)
if $QSUBSCRIPT(X1,3)'=PSN
QUIT
SET INT=$QSUBSCRIPT(X1,5)
SET INT1=^PS(56,INT,0)
IF $PIECE(INT1,"^",2)=ING!($PIECE(INT1,"^",3)=ING)
Begin DoDot:2
+14 KILL ^PS(56,"AI1",ING,INT),^PS(56,"AI2",ING,INT)
+15 KILL @X1,^PS(56,"APD",$QSUBSCRIPT(X1,4),$QSUBSCRIPT(X1,3),$QSUBSCRIPT(X1,5))
+16 SET X2="^PS(56,""AE"")"
FOR
SET X2=$QUERY(@X2)
if $QSUBSCRIPT(X2,3)'=ING
QUIT
IF $QSUBSCRIPT(X2,5)=INT
KILL @X2
KILL ^PS(56,"AE",$QSUBSCRIPT(X2,4),$QSUBSCRIPT(X2,3),$QSUBSCRIPT(X2,5))
End DoDot:2
End DoDot:1
+17 ;
+18 ;ADD INGREDIENT TO CLONIDINE HCL 0.1MG TAB,UD
+19 SET DA=444
SET DA(1)=13554
SET DIC="^PSNDF(50.68,"_DA(1)_",2,"
SET DIC(0)="L"
SET X=DA
SET DINUM=X
DO FILE^DICN
SET DIE=DIC
SET DR="1////0.1;2////20;"
DO ^DIE
+20 KILL DA,DIC,DIE,DINUM,DR,ID,ING,INT,INT1,K,K1,PSN,PSNID,X,X1,X2,^TMP($JOB),^TMP("PSN",$JOB)
+21 QUIT
