PSNPPSNU ;HP/MJE-PPSN update NDF data ; 05 Mar 2014 1:20 PM
;;4.0;NATIONAL DRUG FILE;**513,563,566,569**; 30 Oct 98;Build 3
;Reference to ^PSDRUG supported by DBIA #2192
;Reference to PSN^PSSHUIDG supported by DBIA #3621
;Reference to ^GMR(120.8) supported by DBIA #4606
;Reference to ^DD supported by DBIA #1258
;Reference to ^PSSUTIL supported by DBIA #3107
;
; Note: this routine is an adapted version of the origional code by Dr. Dave Alexander
;
N CL,CLA,CMOP,CT,DA,DA1,DIA,DIC,DIE,DIK,DINUM,DR,FDA,FILE,FLDS,GE,GROOT,GROOT1,IENS,IN,INA,IND,INDX,INV,J,JJ,K
N LI,LINE,NA,NAME,ND,NEW,NFI,POST,PR,PSN,PSN1,PSN11,PSN21,PSNDF,R1,ROOT,ROOT1,ROOT2,ROOT3,SUBS,VAC,VAIN,VAPN
N X,XMDUZ,XMSUB,XMTEXT,XMY,XMZ,TREC,PSNMULTI,MJJ,PSNERROR
N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,XPATH
N PSNPS,XPDIDTOT,RES1,PSNTMPN
K ^TMP($J),^TMP("PSN",$J),^TMP("PSNN",$J),^TMP("PSN PPSN.WP",$J),^TMP("PSN PPSN ERR",$J),^TMP("PSNINGRED",$J)
;
;SETUP PRODUCTION OR SQA
S PSNPS=$P($G(^PS(59.7,1,10)),"^",12),PSNERROR=0
I PSNPS="T"!(PSNPS="S") S PSNPS="P" ;test account and support account is same as production.
S PSNDF=1,XPDIDTOT=+$G(^TMP("PSN PPSN PARSED",$J,"TREC")),TREC=0
;TO ALLOW ADDS TO 56,50.416,50.605,50.606, AND 50.6
;
D DATANT^PSNPPSI1
I PSNPS="N" D POSTRUN^PSNPPSNK
;
WORD ;
D CTRKDL^PSNPPSMS("Storing report messages information")
S FDA(57.231,CTRLXIEN_","_CTRLIEN_",",6)="WORD"
D UPDATE^DIE("","FDA","CTRLIEN")
K FDA
S ROOT1=$NA(^TMP("PSN PPSN PARSED",$J,"WORD")),CT=0,ROOT2=$NA(@ROOT1@(0))
F S CT=$O(@ROOT2) Q:'CT D CTRLSS^PSNPPSMS(CT) S ROOT2=$NA(@ROOT1@(CT)),NAME=@ROOT2,ROOT3=$NA(@ROOT2@("D")) K @NAME M @NAME=@ROOT3
;
D CTRKDL^PSNPPSMS("Sending mail messages")
D MESSAGE^PSNPPSMG
;
D CTRKDL^PSNPPSMS("Beginning un-march/re-match")
W:'$G(PSNSCJOB) !,"Beginning un-match/re-match to local drug file...",!
DRUGFILE ;
;NOW UPDATE LOCAL DRUG FILE
N REM,PSNUNMAT
K ^TMP($J)
I PSNPS="N" S OLDNDF="" F S OLDNDF=$O(^TMP("PSN PPSN PARSED",$J,"REM",OLDNDF)) Q:OLDNDF="" D EN1^PSNPPSNW(OLDNDF,"")
S OLDNDF="",PSN=$$PATCH^XPDUTL("PSS*1.0*34"),PSN1=$$PATCH^XPDUTL("PSS*1.0*42")
S ROOT2=$NA(^TMP("PSN PPSN PARSED",$J,"PRODUCTS TO UNMATCH")),ROOT3=$NA(^TMP("PSN PPSN PARSED",$J,"POE")),DA=0
S DA=0 F S DA=$O(^PSDRUG(DA)) Q:'DA S X=$G(^PSDRUG(DA,0)) I X]"" S NA=$P(X,"^"),CLA=$P(X,"^",2),INV=$P(X,"^",3)["I",X=$G(^("ND")),IN=$P($G(^("I"),9999999),"^"),INA=IN'>DT,GE=+X,PR=+$P(X,"^",3),CMOP=$P(X,"^",10),VAPN=$P(X,"^",2) I GE I PR D
.S OLDNDF=$P($G(^PSDRUG(DA,"ND")),"^",3) ;va product name (3P:50.68); NA = generic name; CLA = VA Class; INV = DEA Special HDLG
.S VAIN=$P($G(^PSNDF(50.68,PR,7)),"^",3) ;inactivation date
.I $D(@ROOT2@(PR))!VAIN S X="" S:CMOP]"" X=" (CMOP "_CMOP_")" D
..S $E(X,30)=VAPN,$E(X,65)=$$FMTE^XLFDT(VAIN,5),INDX=$S(INA:"I",INV:"X",1:"A")
..S:IN=9999999 IN="" S ^TMP($J,INDX,NA_"^"_DA_"^"_IN,1)=X,^TMP($J,"^",DA)=""
..D UNMDRUG^PSSUTIL(DA)
..I PSN I $P($G(^PSDRUG(DA,"DOS")),"^")]""!$O(^("DOS1",0))!$O(^PSDRUG(DA,"DOS2",0)) D LOAD^PSNPPSNV K ^PSDRUG(DA,"DOS"),^("DOS1"),^("DOS2")
..I $P($G(^PSDRUG(DA,3)),"^") S DIE=50,DR="213////0;" D ^DIE D ERROR:$D(ERROR("DIERR")) K DIE,DR I PSN1 S IND=$O(^PSDRUG(DA,4," "),-1),$P(^(IND,0),"^",6)="NDF Update"
.;check here if PR (50.68 IEN this local drug is matched to) exists in TMP rematch
.;if a re-match for that IEN is not null, do re-match (file re-match, add to report)
.S REM="" I OLDNDF'="" S REM=$G(^TMP("PSN PPSN PARSED",$J,"REM",OLDNDF))
.I REM'="" D REMATCH^PSNPPSNW(DA,REM)
.I PSN,$D(@ROOT3@(PR)) K ^PSDRUG(DA,"DOS"),^("DOS1"),^("DOS2")
.S ND=$G(^PSDRUG(DA,"ND")),PR=$P(ND,"^",3) I PR D
..S NFI=$P($G(^PSNDF(50.68,PR,5)),"^") I $P(ND,"^",11)'=NFI S DIE=50,DR="29////"_NFI_";" D ^DIE D ERROR:$D(ERROR("DIERR"))
..S VAC=$P($G(^PSNDF(50.68,PR,3)),"^") I VAC S VAC=$P(^PS(50.605,VAC,0),"^"),DIE=50,DR="2////"_VAC_";" D ^DIE D ERROR:$D(ERROR("DIERR"))
..I $P($G(^PSDRUG(DA,3)),"^"),'$P($G(^PSNDF(50.68,PR,1)),"^",3) S DIE=50,DR="213////0;" D ^DIE D ERROR:$D(ERROR("DIERR")) K DIE,DR S IND=$O(^PSDRUG(DA,4," "),-1),$P(^(IND,0),"^",6)="NDF Update"
.;S TREC=TREC+1 I '(TREC#500) D UPDATE^XPDID(TREC)
D DRGMSG^PSNPPSMG
;package specific post install
I $D(^TMP("PSN PPSN PARSED",$J,"POST")) S POST=^("POST") S:POST'["^" POST="^"_POST I @("$T("_POST_")]]""""") D @POST
;
;call to HL7 drug update message
I $T(PSN^PSSHUIDG)]"" I $O(^TMP($J,"^",0)) S ZTRTN="PSN^PSSHUIDG",ZTIO="",ZTDTH=$H,ZTDESC="DRUG UPDATE MESSAGE",ZTSAVE("^TMP($J,""^"",")="" D ^%ZTLOAD
;
D CTRKDL^PSNPPSMS("Validating cross references")
W:'$G(PSNSCJOB) !,"Validating cross references...",!
REINDEX ;Make sure APC xref is correct
S FDA(57.231,CTRLXIEN_","_CTRLIEN_",",6)="REINDEX"
D UPDATE^DIE("","FDA","CTRLIEN")
K FDA
N SUB,DA,DIK,GMRAIEN,CLASS
S SUB=0 F S SUB=$O(^GMR(120.8,SUB)) Q:'+SUB I $D(^GMR(120.8,SUB,3)) D
.S GMRAIEN=+$P($G(^GMR(120.8,SUB,0)),U) Q:'GMRAIEN
.S CLASS="" F S CLASS=$O(^GMR(120.8,"APC",GMRAIEN,CLASS)) Q:CLASS="" K ^GMR(120.8,"APC",GMRAIEN,CLASS,SUB)
.S DA(1)=SUB
.S DIK="^GMR(120.8,DA(1),3,"
.S DIK(1)=".01^ADRG3"
.D ENALL^DIK ;Reset the drug class xref
;
MORE ; REINDEXING
D CTRKDL^PSNPPSMS("Reindexing")
;now the APD
K ^PS(50.416,"APD") S DA=0 F S DA=$O(^PS(50.416,DA)),K=0 Q:'DA F S K=$O(^PS(50.416,DA,1,K)) Q:'K S X=^(K,0),^PS(50.416,"APD",X,DA)=""
;now the interactions
K ^PS(56,"APD") S DA=0 F S DA=$O(^PS(56,DA)) Q:'DA K PSN1,PSN2 S PSN1=$P(^(DA,0),"^",2),PSN2=$P(^(0),"^",3) D
.S NA="" F S NA=$O(^PS(50.416,PSN1,1,"B",NA)) Q:NA="" S PSN1(NA)=""
.S PSN11=0 F S PSN11=$O(^PS(50.416,"APS",PSN1,PSN11)),NA="" Q:'PSN11 F S NA=$O(^PS(50.416,PSN11,1,"B",NA)) Q:NA="" S PSN1(NA)=""
.S NA="" F S NA=$O(^PS(50.416,PSN2,1,"B",NA)) Q:NA="" S PSN2(NA)=""
.S PSN21=0 F S PSN21=$O(^PS(50.416,"APS",PSN2,PSN21)),NA="" Q:'PSN21 F S NA=$O(^PS(50.416,PSN21,1,"B",NA)) Q:NA="" S PSN2(NA)=""
.S PSN1="" F S PSN1=$O(PSN1(PSN1)),PSN2="" Q:PSN1="" F S PSN2=$O(PSN2(PSN2)) Q:PSN2="" S ^PS(56,"APD",PSN1,PSN2,DA)="",^PS(56,"APD",PSN2,PSN1,DA)=""
;
D ^PSNPPSCL
D ERRORMS^PSNPPSMS
;
QUIT ;
;D UPDATE^XPDID(XPDIDTOT)
K CL,CLA,CMOP,CT,DA,DA1,DIA,DIC,DIE,DIK,DINUM,DR,FDA,FILE,FLDS,GE,GROOT,GROOT1,IENS,IN,INA,IND,INDX,INV,J,JJ,K,LI,LINE,NA,NAME,ND,NEW,NFI,POST,PR,PSN,PSN1,PSN11,PSN21,PSNDF,R1,ROOT,ROOT1,ROOT2,ROOT3,SUBS,VAC,VAIN,VAPN
K X,XMDUZ,XMSUB,XMTEXT,XMY,XMZ,XUMF,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
K ^TMP($J),^TMP("PSN",$J),^TMP("PSNN",$J),^TMP("PSN PPSN ERR",$J),^TMP("PSNINGRED",$J)
Q
;
ERROR ;Track file errors
D APPERROR^%ZTER("PPSN ERROR")
N PSNERRC,ERRFILE,ERRIEN
S PSNERROR=PSNERROR+1,PSNERRC=0,ERRFILE=0,ERRIEN=0
F S PSNERRC=$O(ERROR("DIERR",PSNERRC)) Q:'PSNERRC D:$D(ERROR("DIERR",PSNERRC,"TEXT",1))
.S ERRFILE=$G(ERROR("DIERR",PSNERRC,"PARAM","FILE")) S ERRIEN=$S("^351^352^311^"[("^"_$G(ERROR("DIERR",PSNERRC))_"^"):" ",1:$P(DIA,"^"))
.S ^TMP("PSN PPSN ERR",$J,PSNTMPN,$S($G(ERRFILE):ERRFILE,$G(FILE)'="":FILE,1:ROOT),ERRIEN,$P(DIA,"^",3),PSNERROR)=ERROR("DIERR",PSNERRC,"TEXT",1)_"|"_$S($G(FILE)'="":FILE,1:ROOT)_"-"_$P(DIA,"^",3)_"|"_NEW
Q
;
ERROR2(PSNERRN,PSNERRF,PSNERRIE,PSNERRFL,PSNERRTY) ;Track DICN errors
D APPERROR^%ZTER("PPSN ERROR2")
S PSNERROR=PSNERROR+1,PSNERRC=""
S ^TMP("PSN PPSN ERR",$J,PSNERRN,PSNERRF,PSNERRIE,PSNERRFL,PSNERRTY)=DIA_"^"_NEW
Q
STRIP(X) ; Strip control characters
N I,Y
S Y="" F I=1:1:$L(X) S:$A(X,I)>31 Y=Y_$E(X,I)
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSNPPSNU 7459 printed Sep 23, 2025@20:00:50 Page 2
PSNPPSNU ;HP/MJE-PPSN update NDF data ; 05 Mar 2014 1:20 PM
+1 ;;4.0;NATIONAL DRUG FILE;**513,563,566,569**; 30 Oct 98;Build 3
+2 ;Reference to ^PSDRUG supported by DBIA #2192
+3 ;Reference to PSN^PSSHUIDG supported by DBIA #3621
+4 ;Reference to ^GMR(120.8) supported by DBIA #4606
+5 ;Reference to ^DD supported by DBIA #1258
+6 ;Reference to ^PSSUTIL supported by DBIA #3107
+7 ;
+8 ; Note: this routine is an adapted version of the origional code by Dr. Dave Alexander
+9 ;
+10 NEW CL,CLA,CMOP,CT,DA,DA1,DIA,DIC,DIE,DIK,DINUM,DR,FDA,FILE,FLDS,GE,GROOT,GROOT1,IENS,IN,INA,IND,INDX,INV,J,JJ,K
+11 NEW LI,LINE,NA,NAME,ND,NEW,NFI,POST,PR,PSN,PSN1,PSN11,PSN21,PSNDF,R1,ROOT,ROOT1,ROOT2,ROOT3,SUBS,VAC,VAIN,VAPN
+12 NEW X,XMDUZ,XMSUB,XMTEXT,XMY,XMZ,TREC,PSNMULTI,MJJ,PSNERROR
+13 NEW ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,XPATH
+14 NEW PSNPS,XPDIDTOT,RES1,PSNTMPN
+15 KILL ^TMP($JOB),^TMP("PSN",$JOB),^TMP("PSNN",$JOB),^TMP("PSN PPSN.WP",$JOB),^TMP("PSN PPSN ERR",$JOB),^TMP("PSNINGRED",$JOB)
+16 ;
+17 ;SETUP PRODUCTION OR SQA
+18 SET PSNPS=$PIECE($GET(^PS(59.7,1,10)),"^",12)
SET PSNERROR=0
+19 ;test account and support account is same as production.
IF PSNPS="T"!(PSNPS="S")
SET PSNPS="P"
+20 SET PSNDF=1
SET XPDIDTOT=+$GET(^TMP("PSN PPSN PARSED",$JOB,"TREC"))
SET TREC=0
+21 ;TO ALLOW ADDS TO 56,50.416,50.605,50.606, AND 50.6
+22 ;
+23 DO DATANT^PSNPPSI1
+24 IF PSNPS="N"
DO POSTRUN^PSNPPSNK
+25 ;
WORD ;
+1 DO CTRKDL^PSNPPSMS("Storing report messages information")
+2 SET FDA(57.231,CTRLXIEN_","_CTRLIEN_",",6)="WORD"
+3 DO UPDATE^DIE("","FDA","CTRLIEN")
+4 KILL FDA
+5 SET ROOT1=$NAME(^TMP("PSN PPSN PARSED",$JOB,"WORD"))
SET CT=0
SET ROOT2=$NAME(@ROOT1@(0))
+6 FOR
SET CT=$ORDER(@ROOT2)
if 'CT
QUIT
DO CTRLSS^PSNPPSMS(CT)
SET ROOT2=$NAME(@ROOT1@(CT))
SET NAME=@ROOT2
SET ROOT3=$NAME(@ROOT2@("D"))
KILL @NAME
MERGE @NAME=@ROOT3
+7 ;
+8 DO CTRKDL^PSNPPSMS("Sending mail messages")
+9 DO MESSAGE^PSNPPSMG
+10 ;
+11 DO CTRKDL^PSNPPSMS("Beginning un-march/re-match")
+12 if '$GET(PSNSCJOB)
WRITE !,"Beginning un-match/re-match to local drug file...",!
DRUGFILE ;
+1 ;NOW UPDATE LOCAL DRUG FILE
+2 NEW REM,PSNUNMAT
+3 KILL ^TMP($JOB)
+4 IF PSNPS="N"
SET OLDNDF=""
FOR
SET OLDNDF=$ORDER(^TMP("PSN PPSN PARSED",$JOB,"REM",OLDNDF))
if OLDNDF=""
QUIT
DO EN1^PSNPPSNW(OLDNDF,"")
+5 SET OLDNDF=""
SET PSN=$$PATCH^XPDUTL("PSS*1.0*34")
SET PSN1=$$PATCH^XPDUTL("PSS*1.0*42")
+6 SET ROOT2=$NAME(^TMP("PSN PPSN PARSED",$JOB,"PRODUCTS TO UNMATCH"))
SET ROOT3=$NAME(^TMP("PSN PPSN PARSED",$JOB,"POE"))
SET DA=0
+7 SET DA=0
FOR
SET DA=$ORDER(^PSDRUG(DA))
if 'DA
QUIT
SET X=$GET(^PSDRUG(DA,0))
IF X]""
SET NA=$PIECE(X,"^")
SET CLA=$PIECE(X,"^",2)
SET INV=$PIECE(X,"^",3)["I"
SET X=$GET(^("ND"))
SET IN=$PIECE($GET(^("I"),9999999),"^")
SET INA=IN'>DT
SET GE=+X
SET PR=+$PIECE(X,"^",3)
SET CMOP=$PIECE(X,"^",10)
SET VAPN=$PIECE(X,"^",2)
IF GE
IF PR
Begin DoDot:1
+8 ;va product name (3P:50.68); NA = generic name; CLA = VA Class; INV = DEA Special HDLG
SET OLDNDF=$PIECE($GET(^PSDRUG(DA,"ND")),"^",3)
+9 ;inactivation date
SET VAIN=$PIECE($GET(^PSNDF(50.68,PR,7)),"^",3)
+10 IF $DATA(@ROOT2@(PR))!VAIN
SET X=""
if CMOP]""
SET X=" (CMOP "_CMOP_")"
Begin DoDot:2
+11 SET $EXTRACT(X,30)=VAPN
SET $EXTRACT(X,65)=$$FMTE^XLFDT(VAIN,5)
SET INDX=$SELECT(INA:"I",INV:"X",1:"A")
+12 if IN=9999999
SET IN=""
SET ^TMP($JOB,INDX,NA_"^"_DA_"^"_IN,1)=X
SET ^TMP($JOB,"^",DA)=""
+13 DO UNMDRUG^PSSUTIL(DA)
+14 IF PSN
IF $PIECE($GET(^PSDRUG(DA,"DOS")),"^")]""!$ORDER(^("DOS1",0))!$ORDER(^PSDRUG(DA,"DOS2",0))
DO LOAD^PSNPPSNV
KILL ^PSDRUG(DA,"DOS"),^("DOS1"),^("DOS2")
+15 IF $PIECE($GET(^PSDRUG(DA,3)),"^")
SET DIE=50
SET DR="213////0;"
DO ^DIE
if $DATA(ERROR("DIERR"))
DO ERROR
KILL DIE,DR
IF PSN1
SET IND=$ORDER(^PSDRUG(DA,4," "),-1)
SET $PIECE(^(IND,0),"^",6)="NDF Update"
End DoDot:2
+16 ;check here if PR (50.68 IEN this local drug is matched to) exists in TMP rematch
+17 ;if a re-match for that IEN is not null, do re-match (file re-match, add to report)
+18 SET REM=""
IF OLDNDF'=""
SET REM=$GET(^TMP("PSN PPSN PARSED",$JOB,"REM",OLDNDF))
+19 IF REM'=""
DO REMATCH^PSNPPSNW(DA,REM)
+20 IF PSN
IF $DATA(@ROOT3@(PR))
KILL ^PSDRUG(DA,"DOS"),^("DOS1"),^("DOS2")
+21 SET ND=$GET(^PSDRUG(DA,"ND"))
SET PR=$PIECE(ND,"^",3)
IF PR
Begin DoDot:2
+22 SET NFI=$PIECE($GET(^PSNDF(50.68,PR,5)),"^")
IF $PIECE(ND,"^",11)'=NFI
SET DIE=50
SET DR="29////"_NFI_";"
DO ^DIE
if $DATA(ERROR("DIERR"))
DO ERROR
+23 SET VAC=$PIECE($GET(^PSNDF(50.68,PR,3)),"^")
IF VAC
SET VAC=$PIECE(^PS(50.605,VAC,0),"^")
SET DIE=50
SET DR="2////"_VAC_";"
DO ^DIE
if $DATA(ERROR("DIERR"))
DO ERROR
+24 IF $PIECE($GET(^PSDRUG(DA,3)),"^")
IF '$PIECE($GET(^PSNDF(50.68,PR,1)),"^",3)
SET DIE=50
SET DR="213////0;"
DO ^DIE
if $DATA(ERROR("DIERR"))
DO ERROR
KILL DIE,DR
SET IND=$ORDER(^PSDRUG(DA,4," "),-1)
SET $PIECE(^(IND,0),"^",6)="NDF Update"
End DoDot:2
+25 ;S TREC=TREC+1 I '(TREC#500) D UPDATE^XPDID(TREC)
End DoDot:1
+26 DO DRGMSG^PSNPPSMG
+27 ;package specific post install
+28 IF $DATA(^TMP("PSN PPSN PARSED",$JOB,"POST"))
SET POST=^("POST")
if POST'["^"
SET POST="^"_POST
IF @("$T("_POST_")]]""""")
DO @POST
+29 ;
+30 ;call to HL7 drug update message
+31 IF $TEXT(PSN^PSSHUIDG)]""
IF $ORDER(^TMP($JOB,"^",0))
SET ZTRTN="PSN^PSSHUIDG"
SET ZTIO=""
SET ZTDTH=$HOROLOG
SET ZTDESC="DRUG UPDATE MESSAGE"
SET ZTSAVE("^TMP($J,""^"",")=""
DO ^%ZTLOAD
+32 ;
+33 DO CTRKDL^PSNPPSMS("Validating cross references")
+34 if '$GET(PSNSCJOB)
WRITE !,"Validating cross references...",!
REINDEX ;Make sure APC xref is correct
+1 SET FDA(57.231,CTRLXIEN_","_CTRLIEN_",",6)="REINDEX"
+2 DO UPDATE^DIE("","FDA","CTRLIEN")
+3 KILL FDA
+4 NEW SUB,DA,DIK,GMRAIEN,CLASS
+5 SET SUB=0
FOR
SET SUB=$ORDER(^GMR(120.8,SUB))
if '+SUB
QUIT
IF $DATA(^GMR(120.8,SUB,3))
Begin DoDot:1
+6 SET GMRAIEN=+$PIECE($GET(^GMR(120.8,SUB,0)),U)
if 'GMRAIEN
QUIT
+7 SET CLASS=""
FOR
SET CLASS=$ORDER(^GMR(120.8,"APC",GMRAIEN,CLASS))
if CLASS=""
QUIT
KILL ^GMR(120.8,"APC",GMRAIEN,CLASS,SUB)
+8 SET DA(1)=SUB
+9 SET DIK="^GMR(120.8,DA(1),3,"
+10 SET DIK(1)=".01^ADRG3"
+11 ;Reset the drug class xref
DO ENALL^DIK
End DoDot:1
+12 ;
MORE ; REINDEXING
+1 DO CTRKDL^PSNPPSMS("Reindexing")
+2 ;now the APD
+3 KILL ^PS(50.416,"APD")
SET DA=0
FOR
SET DA=$ORDER(^PS(50.416,DA))
SET K=0
if 'DA
QUIT
FOR
SET K=$ORDER(^PS(50.416,DA,1,K))
if 'K
QUIT
SET X=^(K,0)
SET ^PS(50.416,"APD",X,DA)=""
+4 ;now the interactions
+5 KILL ^PS(56,"APD")
SET DA=0
FOR
SET DA=$ORDER(^PS(56,DA))
if 'DA
QUIT
KILL PSN1,PSN2
SET PSN1=$PIECE(^(DA,0),"^",2)
SET PSN2=$PIECE(^(0),"^",3)
Begin DoDot:1
+6 SET NA=""
FOR
SET NA=$ORDER(^PS(50.416,PSN1,1,"B",NA))
if NA=""
QUIT
SET PSN1(NA)=""
+7 SET PSN11=0
FOR
SET PSN11=$ORDER(^PS(50.416,"APS",PSN1,PSN11))
SET NA=""
if 'PSN11
QUIT
FOR
SET NA=$ORDER(^PS(50.416,PSN11,1,"B",NA))
if NA=""
QUIT
SET PSN1(NA)=""
+8 SET NA=""
FOR
SET NA=$ORDER(^PS(50.416,PSN2,1,"B",NA))
if NA=""
QUIT
SET PSN2(NA)=""
+9 SET PSN21=0
FOR
SET PSN21=$ORDER(^PS(50.416,"APS",PSN2,PSN21))
SET NA=""
if 'PSN21
QUIT
FOR
SET NA=$ORDER(^PS(50.416,PSN21,1,"B",NA))
if NA=""
QUIT
SET PSN2(NA)=""
+10 SET PSN1=""
FOR
SET PSN1=$ORDER(PSN1(PSN1))
SET PSN2=""
if PSN1=""
QUIT
FOR
SET PSN2=$ORDER(PSN2(PSN2))
if PSN2=""
QUIT
SET ^PS(56,"APD",PSN1,PSN2,DA)=""
SET ^PS(56,"APD",PSN2,PSN1,DA)=""
End DoDot:1
+11 ;
+12 DO ^PSNPPSCL
+13 DO ERRORMS^PSNPPSMS
+14 ;
QUIT ;
+1 ;D UPDATE^XPDID(XPDIDTOT)
+2 KILL CL,CLA,CMOP,CT,DA,DA1,DIA,DIC,DIE,DIK,DINUM,DR,FDA,FILE,FLDS,GE,GROOT,GROOT1,IENS,IN,INA,IND,INDX,INV,J,JJ,K,LI,LINE,NA,NAME,ND,NEW,NFI,POST,PR,PSN,PSN1,PSN11,PSN21,PSNDF,R1,ROOT,ROOT1,ROOT2,ROOT3,SUBS,VAC,VAIN,VAPN
+3 KILL X,XMDUZ,XMSUB,XMTEXT,XMY,XMZ,XUMF,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
+4 KILL ^TMP($JOB),^TMP("PSN",$JOB),^TMP("PSNN",$JOB),^TMP("PSN PPSN ERR",$JOB),^TMP("PSNINGRED",$JOB)
+5 QUIT
+6 ;
ERROR ;Track file errors
+1 DO APPERROR^%ZTER("PPSN ERROR")
+2 NEW PSNERRC,ERRFILE,ERRIEN
+3 SET PSNERROR=PSNERROR+1
SET PSNERRC=0
SET ERRFILE=0
SET ERRIEN=0
+4 FOR
SET PSNERRC=$ORDER(ERROR("DIERR",PSNERRC))
if 'PSNERRC
QUIT
if $DATA(ERROR("DIERR",PSNERRC,"TEXT",1))
Begin DoDot:1
+5 SET ERRFILE=$GET(ERROR("DIERR",PSNERRC,"PARAM","FILE"))
SET ERRIEN=$SELECT("^351^352^311^"[("^"_$GET(ERROR("DIERR",PSNERRC))_"^"):" ",1:$PIECE(DIA,"^"))
+6 SET ^TMP("PSN PPSN ERR",$JOB,PSNTMPN,$SELECT($GET(ERRFILE):ERRFILE,$GET(FILE)'="":FILE,1:ROOT),ERRIEN,$PIECE(DIA,"^",3),PSNERROR)=ERROR("DIERR",PSNERRC,"TEXT",1)_"|"_$SELECT($GET(FILE)'="":FILE,1:ROOT)_"-"_$PIECE(DIA,"^",3)_"|"_NEW
End DoDot:1
+7 QUIT
+8 ;
ERROR2(PSNERRN,PSNERRF,PSNERRIE,PSNERRFL,PSNERRTY) ;Track DICN errors
+1 DO APPERROR^%ZTER("PPSN ERROR2")
+2 SET PSNERROR=PSNERROR+1
SET PSNERRC=""
+3 SET ^TMP("PSN PPSN ERR",$JOB,PSNERRN,PSNERRF,PSNERRIE,PSNERRFL,PSNERRTY)=DIA_"^"_NEW
+4 QUIT
STRIP(X) ; Strip control characters
+1 NEW I,Y
+2 SET Y=""
FOR I=1:1:$LENGTH(X)
if $ASCII(X,I)>31
SET Y=Y_$EXTRACT(X,I)
+3 QUIT Y
