PSNPPSI3 ;HP/MJE-PPSN update NDF data for parsing DATAO records ; 05 Mar 2014 1:20 PM
;;4.0;NATIONAL DRUG FILE;**513,565**; 30 Oct 98;Build 16
;Reference to ^DD supported by DBIA #1258
;
Q
;
;This routine parses DATAO records which are edits to existing file entries
DATAO ;
K XFILE,XFLDS
K FDA
S FDA(57.231,CTRLXIEN_","_CTRLIEN_",",6)="DATAO",PSNTMPN="DATAO"
D UPDATE^DIE("","FDA","CTRLIEN")
K FDA
D CTRLFILE^PSNPPSMS(0)
D CTRLSS^PSNPPSMS(0)
D CTRLIEN^PSNPPSMS(0)
S (OJJ,FILE)=0,GROOT=$NA(^TMP("PSN PPSN PARSED",$J,"DATAO"))
;now load the rest of the data
F S FILE=$O(@GROOT@(FILE)) Q:'FILE D CTRLFILE^PSNPPSMS(FILE) S ROOT=$$ROOT^DILFD(FILE) I ROOT]"" S GROOT1=$NA(@GROOT@(FILE)) F JJ=1:2 Q:'$D(@GROOT1@(JJ)) D
.S (DIA,NEW)=""
.S DIA=@GROOT1@(JJ) I $G(@GROOT1@(JJ+1))]"" S NEW=@GROOT1@(JJ+1)
.S ^TMP("PSN PPSN PARSED",$J,"AE_PRODUCTS",+DIA)=""
.D CTRLSS^PSNPPSMS($TR(GROOT1,"^")_","_JJ)
.;
.I $G(PSNMULTI) D
..S (MIENS,MFLDS)="",MIENS=$P(DIA,"^")_",",MFLDS=$P(DIA,"^",3)
..I MFLDS'=""&($P(NEW,"^")'=MIENS) S PSNMULTI=0,^TMP("PSN PPSN.WPXRF",$J,FILE,OIENS,OFLDS)=""
.S IENS=$P(DIA,"^")_",",FLDS=$P(DIA,"^",3),ROOT=FILE K FDA,IEN
.;
.I FILE=50.68 D UNMATCH^PSNPPSI2
.;
.K RES1
.I '$G(PSNMULTI) D FIELD^DID(FILE,FLDS,"","TYPE","RES1")
.I $G(RES1("TYPE"))="WORD-PROCESSING"!$G(PSNMULTI) D Q
..I '$G(PSNMULTI) D
...S MJJ=JJ,OIENS=IENS,OFLDS=FLDS
...I $D(^TMP("PSN PPSN.WPXRF",$J,FILE,IENS,FLDS)) K ^TMP("PSN PPSN.WP",$J,FILE,OIENS,OFLDS),^TMP("PSN PPSN.WPXRF",$J,FILE,IENS,FLDS)
...;Set 5000 file for word processing fields
...S PSNWP=$$GET1^DID(FILE,"","","GLOBAL NAME")_$P(DIA,"^")_"," ;"PSNDF(FILE,"_IENS_",1)"
...D FIELD^DID(FILE,FLDS,"Z","GLOBAL SUBSCRIPT LOCATION","RES2")
...S RES3="",RES3=$P(RES2("GLOBAL SUBSCRIPT LOCATION"),";")
...S PSNWP=PSNWP_$S(RES3?1AN.AN:""""_RES3_"""",1:RES3)_")"
...I PSNPS="N",'$D(^NDFK(5000,1,4,"B",PSNWP)) S X=$O(^NDFK(5000,1,4," "),-1)+1,^(X,0)=PSNWP,^NDFK(5000,1,4,"B",PSNWP,X)=""
..;
..I '$P(DIA,"^",3) S ^TMP("PSN PPSN.WP",$J,FILE,OIENS,OFLDS,MJJ)=$$STRIP^PSNPPSNU(DIA),MJJ=MJJ+1
..I '$P(NEW,"^",3) S ^TMP("PSN PPSN.WP",$J,FILE,OIENS,OFLDS,MJJ)=$$STRIP^PSNPPSNU(NEW),PSNMULTI=1,MJJ=MJJ+1
..I $P(NEW,"^",3)'="" S JJ=JJ-1
.;
.S XFILE=FILE
.I FLDS["," D
..I FILE=50.68,$P($P(DIA,"^",3),",")=43 D MULTIPLE^PSNPPSI2 Q ;new generic multiple .01 field code
..S LI=$P(DIA,"^",3) F J=1:1:$L(LI,",")-1 S ROOT=+$P(^DD(ROOT,+$P(LI,",",J),0),"^",2)
..S LI=$P(DIA,"^"),IENS="" F J=$L(LI,","):-1:1 S IENS=IENS_$P(LI,",",J)_"," S ^TMP("PSN PPSN PARSED",$J,"AE_PRODUCTS",$P(LI,",",J))=""
..S XFLDS=$P(FLDS,",",$L(FLDS,",")-1) I $G(XFLDS)'="" S XFILE=+$P(^DD(FILE,XFLDS,0),"^",2) S:$G(XFILE)="" XFILE=FILE
..S FLDS=$P(FLDS,",",$L(FLDS,","))
.S DA=+IENS
.D CTRLIEN^PSNPPSMS(IENS)
.I FILE=50.68,$P($P(DIA,"^",3),",")=43 Q
.;
.I PSNPS="N",FILE=50.68 D
..D NDFK^PSNPPSNK
..I FLDS=31 D
...K ORDP,ORDN,ERROR
...S ORDP=$$GET1^DIQ(50.68,+IENS_",",31,"I","ERROR")
...S ORDN=NEW
...S ^TMP("PSN PPSN PARSED",$J,"POST_RUN",5000.608,FILE,+IENS,FLDS)=ORDP_"^"_ORDN
..I $P(DIA,"^",3)="14,.01" S ^TMP("PSN PPSN PARSED",$J,"POST_RUN",5000.509,FILE,IENS,FLDS)=NEW
.;
.D CLASS:FILE=50.68
.;new generic multiple .01 field code
.I FILE=50.68,$P($P(DIA,"^",3),",")=43 Q
.;
.I FILE=50.68,$P(DIA,"^",3)="21" D K FDA
..K FDA,ERROR
..D NOW^%DTC
..S FDA(50.6899,"+1,"_IENS,.01)=$S(NEW="":$P(%,"."),1:NEW),FDA(50.6899,"+1,"_IENS,.02)=$S(NEW="":1,1:0)
..D UPDATE^DIE("","FDA","","ERROR") D ERROR^PSNPPSNU:$D(ERROR("DIERR")) K FDA
.I PSNPS="N" D
..I FILE=50.416 D INGRED^PSNPPSNK
..I FILE=56 D 56^PSNPPSMS(FILE,DIA,NEW,PSNTMPN)
.I PSNPS="N",FILE=50.67&($P(DIA,"^",3)=1) D
.. S ^TMP("PSN PPSN PARSED",$J,"POST_RUN",50.628,FILE,+DIA,1)=NEW
.;****************************************************** 47
.I FILE[50.68,$P(DIA,"^",3)="45,1"!($P(DIA,"^",3)="45,2") K DIE D Q ;**COPAY TIERS
..K FDA,ERROR
..S DA=$P($P(DIA,"^"),",",2),FDA(50.6845,IENS,$P($P(DIA,"^",3),",",2))=NEW D FILE^DIE("","FDA","ERROR") D ERROR^PSNPPSNU:$D(ERROR("DIERR"))
..K FDA
.;50.606 DOSAGE FORM UNITS
.I FILE[50.606,$P(DIA,"^",3)="8,1" K DIE D Q
..K FDA,ERROR
..S DA=$P($P(DIA,"^"),",",2),FDA(50.6068,IENS,$P($P(DIA,"^",3),",",2))=NEW D FILE^DIE("","FDA","ERROR") D ERROR^PSNPPSNU:$D(ERROR("DIERR"))
..K FDA
.;50.606 DISPENSE UNITS PER DOSE
.I FILE[50.606,$P(DIA,"^",3)="9,1" K DIE D Q
..K FDA,ERROR
..S DA=$P($P(DIA,"^"),",",2),FDA(50.6069,IENS,$P($P(DIA,"^",3),",",2))=NEW D FILE^DIE("","FDA","ERROR") D ERROR^PSNPPSNU:$D(ERROR("DIERR"))
..K FDA
.;50
.I $P(DIA,"^",3)="99.991,.01" D K FDA Q
..K FDA,ERROR
..S FDA(ROOT,"+"_IENS,FLDS)=NEW D UPDATE^DIE("","FDA","","ERROR") D ERROR K FDA
.;
.I $P(DIA,"^",3)="99.991,.02" D K FDA Q
..K FDA,ERROR
..S DA=999999999999 S DA=$O(^PS(FILE,$P(DIA,"^"),"TERMSTATUS",DA),-1) S:DA="" DA=1
..I FILE=50.6!(FILE=50.68) S DA=999999999999 S DA=$O(^PSNDF(FILE,+$P(DIA,"^"),"TERMSTATUS",DA),-1)
..S $P(IENS,",",1)=DA,FDA(ROOT,IENS,.02)=NEW D UPDATE^DIE("","FDA","IEN","ERROR") D ERROR K FDA
.;
.;delete sub-field entries if NEW="", means it was removed from the product in PPS-N
.I FILE=50.68&($P(DIA,"^",3)="14,.01")&(NEW="") D Q
..N DA,DIK,DIAU
..S DA(1)=$P($P(DIA,"^"),","),ROOT3="^PSNDF(50.68,DA(1),2," ;,ROOT3="^"_XPATH_DA(1)_",2,"
..S DIK=ROOT3,DA=$P($P(DIA,"^"),",",2) D ^DIK K DIK,DIAU
.;set fields 14,1 and 14,2
.I FILE=50.68&($P(DIA,"^",3)["14,") D Q
..S DA(1)=$P($P(DIA,"^"),","),XPATH=$P(^DD(ROOT,.01,0),"^",3),ROOT3="^"_XPATH_DA(1)_",2,"
..K FDA,ERROR S FDA(ROOT,IENS,FLDS)=NEW D UPDATE^DIE("","FDA",DA,"ERROR") D ERROR
.;
.;HAZARDOUS TO DISPOSE FIELD 102 = ZERO; KILL FIELDS 103,104,105
.I FILE=50.68&($P(DIA,"^",3)=102),NEW=0 D
..S DA=+$P(DIA,"^"),$P(^PSNDF(50.68,DA,"HAZTODIS"),"^",2)="",$P(^PSNDF(50.68,DA,"HAZTODIS"),"^",3)=""
..K ^PSNDF(50.68,DA,"HAZTODIS2")
.;
.I IENS["," K FDA,ERROR S FDA(ROOT,IENS,FLDS)=NEW D FILE^DIE("","FDA","ERROR") D ERROR K FDA,ERROR Q
.K FDA,ERROR S FDA(FILE,IENS,FLDS)=NEW D FILE^DIE("","FDA","ERROR") D ERROR
.K FDA,ERROR
K XFILE,XFLDS
;
DATAO2 ;
S JJ=0 F S JJ=$O(^TMP("PSNN",$J,JJ)) Q:'JJ S DA=$P(JJ,",",2),DA(1)=+JJ D
. I '$D(^PSNDF(50.68,DA(1),0)) D ERROR2^PSNPPSNU(PSNTMPN,ROOT,IENS,DA(1),"VA PRODUCT entry does not exist.") Q
. D ING^PSNXREF
S FILE="" F S FILE=$O(^TMP("PSN PPSN.WP",$J,FILE)) Q:FILE="" D
. S IENS="" F S IENS=$O(^TMP("PSN PPSN.WP",$J,FILE,IENS)) Q:IENS="" D
.. S FLDS="" F S FLDS=$O(^TMP("PSN PPSN.WP",$J,FILE,IENS,FLDS)) Q:FLDS="" D
... K TMP,ERR
... S JJ=0 F S JJ=$O(^TMP("PSN PPSN.WP",$J,FILE,IENS,FLDS,JJ)) Q:'JJ D
.... S TMP(JJ)=^TMP("PSN PPSN.WP",$J,FILE,IENS,FLDS,JJ)
... D WP^DIE(FILE,IENS,FLDS,"","TMP","ERR")
K ^TMP("PSN PPSN.WP",$J)
Q
;
ERROR ;
D ERROR^PSNPPSNU:$D(ERROR("DIERR"))
Q
;
CLASS ;
I $P(DIA,"^",3)=15 D
.S OLDV=$$GET1^DIQ(50.68,$P(DIA,"^"),15,"I"),VAGEN=$$GET1^DIQ(50.68,$P(DIA,"^"),.05,"I")
.S VAGENN=$$GET1^DIQ(50.68,$P(DIA,"^"),.05,"E")
.;Does not record class/edits on new VA Products same as NDFRR3 & PSSMIGRR routine
.I OLDV'="",(OLDV'=NEW) S ^TMP("PSN PPSN PARSED",$J,"PRODS CHANGED CLASSES",$P(DIA,"^"))=OLDV_"^"_NEW_"^"_VAGEN_"^"_VAGENN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSNPPSI3 7260 printed Dec 13, 2024@02:24:41 Page 2
PSNPPSI3 ;HP/MJE-PPSN update NDF data for parsing DATAO records ; 05 Mar 2014 1:20 PM
+1 ;;4.0;NATIONAL DRUG FILE;**513,565**; 30 Oct 98;Build 16
+2 ;Reference to ^DD supported by DBIA #1258
+3 ;
+4 QUIT
+5 ;
+6 ;This routine parses DATAO records which are edits to existing file entries
DATAO ;
+1 KILL XFILE,XFLDS
+2 KILL FDA
+3 SET FDA(57.231,CTRLXIEN_","_CTRLIEN_",",6)="DATAO"
SET PSNTMPN="DATAO"
+4 DO UPDATE^DIE("","FDA","CTRLIEN")
+5 KILL FDA
+6 DO CTRLFILE^PSNPPSMS(0)
+7 DO CTRLSS^PSNPPSMS(0)
+8 DO CTRLIEN^PSNPPSMS(0)
+9 SET (OJJ,FILE)=0
SET GROOT=$NAME(^TMP("PSN PPSN PARSED",$JOB,"DATAO"))
+10 ;now load the rest of the data
+11 FOR
SET FILE=$ORDER(@GROOT@(FILE))
if 'FILE
QUIT
DO CTRLFILE^PSNPPSMS(FILE)
SET ROOT=$$ROOT^DILFD(FILE)
IF ROOT]""
SET GROOT1=$NAME(@GROOT@(FILE))
FOR JJ=1:2
if '$DATA(@GROOT1@(JJ))
QUIT
Begin DoDot:1
+12 SET (DIA,NEW)=""
+13 SET DIA=@GROOT1@(JJ)
IF $GET(@GROOT1@(JJ+1))]""
SET NEW=@GROOT1@(JJ+1)
+14 SET ^TMP("PSN PPSN PARSED",$JOB,"AE_PRODUCTS",+DIA)=""
+15 DO CTRLSS^PSNPPSMS($TRANSLATE(GROOT1,"^")_","_JJ)
+16 ;
+17 IF $GET(PSNMULTI)
Begin DoDot:2
+18 SET (MIENS,MFLDS)=""
SET MIENS=$PIECE(DIA,"^")_","
SET MFLDS=$PIECE(DIA,"^",3)
+19 IF MFLDS'=""&($PIECE(NEW,"^")'=MIENS)
SET PSNMULTI=0
SET ^TMP("PSN PPSN.WPXRF",$JOB,FILE,OIENS,OFLDS)=""
End DoDot:2
+20 SET IENS=$PIECE(DIA,"^")_","
SET FLDS=$PIECE(DIA,"^",3)
SET ROOT=FILE
KILL FDA,IEN
+21 ;
+22 IF FILE=50.68
DO UNMATCH^PSNPPSI2
+23 ;
+24 KILL RES1
+25 IF '$GET(PSNMULTI)
DO FIELD^DID(FILE,FLDS,"","TYPE","RES1")
+26 IF $GET(RES1("TYPE"))="WORD-PROCESSING"!$GET(PSNMULTI)
Begin DoDot:2
+27 IF '$GET(PSNMULTI)
Begin DoDot:3
+28 SET MJJ=JJ
SET OIENS=IENS
SET OFLDS=FLDS
+29 IF $DATA(^TMP("PSN PPSN.WPXRF",$JOB,FILE,IENS,FLDS))
KILL ^TMP("PSN PPSN.WP",$JOB,FILE,OIENS,OFLDS),^TMP("PSN PPSN.WPXRF",$JOB,FILE,IENS,FLDS)
+30 ;Set 5000 file for word processing fields
+31 ;"PSNDF(FILE,"_IENS_",1)"
SET PSNWP=$$GET1^DID(FILE,"","","GLOBAL NAME")_$PIECE(DIA,"^")_","
+32 DO FIELD^DID(FILE,FLDS,"Z","GLOBAL SUBSCRIPT LOCATION","RES2")
+33 SET RES3=""
SET RES3=$PIECE(RES2("GLOBAL SUBSCRIPT LOCATION"),";")
+34 SET PSNWP=PSNWP_$SELECT(RES3?1AN.AN:""""_RES3_"""",1:RES3)_")"
+35 IF PSNPS="N"
IF '$DATA(^NDFK(5000,1,4,"B",PSNWP))
SET X=$ORDER(^NDFK(5000,1,4," "),-1)+1
SET ^(X,0)=PSNWP
SET ^NDFK(5000,1,4,"B",PSNWP,X)=""
End DoDot:3
+36 ;
+37 IF '$PIECE(DIA,"^",3)
SET ^TMP("PSN PPSN.WP",$JOB,FILE,OIENS,OFLDS,MJJ)=$$STRIP^PSNPPSNU(DIA)
SET MJJ=MJJ+1
+38 IF '$PIECE(NEW,"^",3)
SET ^TMP("PSN PPSN.WP",$JOB,FILE,OIENS,OFLDS,MJJ)=$$STRIP^PSNPPSNU(NEW)
SET PSNMULTI=1
SET MJJ=MJJ+1
+39 IF $PIECE(NEW,"^",3)'=""
SET JJ=JJ-1
End DoDot:2
QUIT
+40 ;
+41 SET XFILE=FILE
+42 IF FLDS[","
Begin DoDot:2
+43 ;new generic multiple .01 field code
IF FILE=50.68
IF $PIECE($PIECE(DIA,"^",3),",")=43
DO MULTIPLE^PSNPPSI2
QUIT
+44 SET LI=$PIECE(DIA,"^",3)
FOR J=1:1:$LENGTH(LI,",")-1
SET ROOT=+$PIECE(^DD(ROOT,+$PIECE(LI,",",J),0),"^",2)
+45 SET LI=$PIECE(DIA,"^")
SET IENS=""
FOR J=$LENGTH(LI,","):-1:1
SET IENS=IENS_$PIECE(LI,",",J)_","
SET ^TMP("PSN PPSN PARSED",$JOB,"AE_PRODUCTS",$PIECE(LI,",",J))=""
+46 SET XFLDS=$PIECE(FLDS,",",$LENGTH(FLDS,",")-1)
IF $GET(XFLDS)'=""
SET XFILE=+$PIECE(^DD(FILE,XFLDS,0),"^",2)
if $GET(XFILE)=""
SET XFILE=FILE
+47 SET FLDS=$PIECE(FLDS,",",$LENGTH(FLDS,","))
End DoDot:2
+48 SET DA=+IENS
+49 DO CTRLIEN^PSNPPSMS(IENS)
+50 IF FILE=50.68
IF $PIECE($PIECE(DIA,"^",3),",")=43
QUIT
+51 ;
+52 IF PSNPS="N"
IF FILE=50.68
Begin DoDot:2
+53 DO NDFK^PSNPPSNK
+54 IF FLDS=31
Begin DoDot:3
+55 KILL ORDP,ORDN,ERROR
+56 SET ORDP=$$GET1^DIQ(50.68,+IENS_",",31,"I","ERROR")
+57 SET ORDN=NEW
+58 SET ^TMP("PSN PPSN PARSED",$JOB,"POST_RUN",5000.608,FILE,+IENS,FLDS)=ORDP_"^"_ORDN
End DoDot:3
+59 IF $PIECE(DIA,"^",3)="14,.01"
SET ^TMP("PSN PPSN PARSED",$JOB,"POST_RUN",5000.509,FILE,IENS,FLDS)=NEW
End DoDot:2
+60 ;
+61 if FILE=50.68
DO CLASS
+62 ;new generic multiple .01 field code
+63 IF FILE=50.68
IF $PIECE($PIECE(DIA,"^",3),",")=43
QUIT
+64 ;
+65 IF FILE=50.68
IF $PIECE(DIA,"^",3)="21"
Begin DoDot:2
+66 KILL FDA,ERROR
+67 DO NOW^%DTC
+68 SET FDA(50.6899,"+1,"_IENS,.01)=$SELECT(NEW="":$PIECE(%,"."),1:NEW)
SET FDA(50.6899,"+1,"_IENS,.02)=$SELECT(NEW="":1,1:0)
+69 DO UPDATE^DIE("","FDA","","ERROR")
if $DATA(ERROR("DIERR"))
DO ERROR^PSNPPSNU
KILL FDA
End DoDot:2
KILL FDA
+70 IF PSNPS="N"
Begin DoDot:2
+71 IF FILE=50.416
DO INGRED^PSNPPSNK
+72 IF FILE=56
DO 56^PSNPPSMS(FILE,DIA,NEW,PSNTMPN)
End DoDot:2
+73 IF PSNPS="N"
IF FILE=50.67&($PIECE(DIA,"^",3)=1)
Begin DoDot:2
+74 SET ^TMP("PSN PPSN PARSED",$JOB,"POST_RUN",50.628,FILE,+DIA,1)=NEW
End DoDot:2
+75 ;****************************************************** 47
+76 ;**COPAY TIERS
IF FILE[50.68
IF $PIECE(DIA,"^",3)="45,1"!($PIECE(DIA,"^",3)="45,2")
KILL DIE
Begin DoDot:2
+77 KILL FDA,ERROR
+78 SET DA=$PIECE($PIECE(DIA,"^"),",",2)
SET FDA(50.6845,IENS,$PIECE($PIECE(DIA,"^",3),",",2))=NEW
DO FILE^DIE("","FDA","ERROR")
if $DATA(ERROR("DIERR"))
DO ERROR^PSNPPSNU
+79 KILL FDA
End DoDot:2
QUIT
+80 ;50.606 DOSAGE FORM UNITS
+81 IF FILE[50.606
IF $PIECE(DIA,"^",3)="8,1"
KILL DIE
Begin DoDot:2
+82 KILL FDA,ERROR
+83 SET DA=$PIECE($PIECE(DIA,"^"),",",2)
SET FDA(50.6068,IENS,$PIECE($PIECE(DIA,"^",3),",",2))=NEW
DO FILE^DIE("","FDA","ERROR")
if $DATA(ERROR("DIERR"))
DO ERROR^PSNPPSNU
+84 KILL FDA
End DoDot:2
QUIT
+85 ;50.606 DISPENSE UNITS PER DOSE
+86 IF FILE[50.606
IF $PIECE(DIA,"^",3)="9,1"
KILL DIE
Begin DoDot:2
+87 KILL FDA,ERROR
+88 SET DA=$PIECE($PIECE(DIA,"^"),",",2)
SET FDA(50.6069,IENS,$PIECE($PIECE(DIA,"^",3),",",2))=NEW
DO FILE^DIE("","FDA","ERROR")
if $DATA(ERROR("DIERR"))
DO ERROR^PSNPPSNU
+89 KILL FDA
End DoDot:2
QUIT
+90 ;50
+91 IF $PIECE(DIA,"^",3)="99.991,.01"
Begin DoDot:2
+92 KILL FDA,ERROR
+93 SET FDA(ROOT,"+"_IENS,FLDS)=NEW
DO UPDATE^DIE("","FDA","","ERROR")
DO ERROR
KILL FDA
End DoDot:2
KILL FDA
QUIT
+94 ;
+95 IF $PIECE(DIA,"^",3)="99.991,.02"
Begin DoDot:2
+96 KILL FDA,ERROR
+97 SET DA=999999999999
SET DA=$ORDER(^PS(FILE,$PIECE(DIA,"^"),"TERMSTATUS",DA),-1)
if DA=""
SET DA=1
+98 IF FILE=50.6!(FILE=50.68)
SET DA=999999999999
SET DA=$ORDER(^PSNDF(FILE,+$PIECE(DIA,"^"),"TERMSTATUS",DA),-1)
+99 SET $PIECE(IENS,",",1)=DA
SET FDA(ROOT,IENS,.02)=NEW
DO UPDATE^DIE("","FDA","IEN","ERROR")
DO ERROR
KILL FDA
End DoDot:2
KILL FDA
QUIT
+100 ;
+101 ;delete sub-field entries if NEW="", means it was removed from the product in PPS-N
+102 IF FILE=50.68&($PIECE(DIA,"^",3)="14,.01")&(NEW="")
Begin DoDot:2
+103 NEW DA,DIK,DIAU
+104 ;,ROOT3="^"_XPATH_DA(1)_",2,"
SET DA(1)=$PIECE($PIECE(DIA,"^"),",")
SET ROOT3="^PSNDF(50.68,DA(1),2,"
+105 SET DIK=ROOT3
SET DA=$PIECE($PIECE(DIA,"^"),",",2)
DO ^DIK
KILL DIK,DIAU
End DoDot:2
QUIT
+106 ;set fields 14,1 and 14,2
+107 IF FILE=50.68&($PIECE(DIA,"^",3)["14,")
Begin DoDot:2
+108 SET DA(1)=$PIECE($PIECE(DIA,"^"),",")
SET XPATH=$PIECE(^DD(ROOT,.01,0),"^",3)
SET ROOT3="^"_XPATH_DA(1)_",2,"
+109 KILL FDA,ERROR
SET FDA(ROOT,IENS,FLDS)=NEW
DO UPDATE^DIE("","FDA",DA,"ERROR")
DO ERROR
End DoDot:2
QUIT
+110 ;
+111 ;HAZARDOUS TO DISPOSE FIELD 102 = ZERO; KILL FIELDS 103,104,105
+112 IF FILE=50.68&($PIECE(DIA,"^",3)=102)
IF NEW=0
Begin DoDot:2
+113 SET DA=+$PIECE(DIA,"^")
SET $PIECE(^PSNDF(50.68,DA,"HAZTODIS"),"^",2)=""
SET $PIECE(^PSNDF(50.68,DA,"HAZTODIS"),"^",3)=""
+114 KILL ^PSNDF(50.68,DA,"HAZTODIS2")
End DoDot:2
+115 ;
+116 IF IENS[","
KILL FDA,ERROR
SET FDA(ROOT,IENS,FLDS)=NEW
DO FILE^DIE("","FDA","ERROR")
DO ERROR
KILL FDA,ERROR
QUIT
+117 KILL FDA,ERROR
SET FDA(FILE,IENS,FLDS)=NEW
DO FILE^DIE("","FDA","ERROR")
DO ERROR
+118 KILL FDA,ERROR
End DoDot:1
+119 KILL XFILE,XFLDS
+120 ;
DATAO2 ;
+1 SET JJ=0
FOR
SET JJ=$ORDER(^TMP("PSNN",$JOB,JJ))
if 'JJ
QUIT
SET DA=$PIECE(JJ,",",2)
SET DA(1)=+JJ
Begin DoDot:1
+2 IF '$DATA(^PSNDF(50.68,DA(1),0))
DO ERROR2^PSNPPSNU(PSNTMPN,ROOT,IENS,DA(1),"VA PRODUCT entry does not exist.")
QUIT
+3 DO ING^PSNXREF
End DoDot:1
+4 SET FILE=""
FOR
SET FILE=$ORDER(^TMP("PSN PPSN.WP",$JOB,FILE))
if FILE=""
QUIT
Begin DoDot:1
+5 SET IENS=""
FOR
SET IENS=$ORDER(^TMP("PSN PPSN.WP",$JOB,FILE,IENS))
if IENS=""
QUIT
Begin DoDot:2
+6 SET FLDS=""
FOR
SET FLDS=$ORDER(^TMP("PSN PPSN.WP",$JOB,FILE,IENS,FLDS))
if FLDS=""
QUIT
Begin DoDot:3
+7 KILL TMP,ERR
+8 SET JJ=0
FOR
SET JJ=$ORDER(^TMP("PSN PPSN.WP",$JOB,FILE,IENS,FLDS,JJ))
if 'JJ
QUIT
Begin DoDot:4
+9 SET TMP(JJ)=^TMP("PSN PPSN.WP",$JOB,FILE,IENS,FLDS,JJ)
End DoDot:4
+10 DO WP^DIE(FILE,IENS,FLDS,"","TMP","ERR")
End DoDot:3
End DoDot:2
End DoDot:1
+11 KILL ^TMP("PSN PPSN.WP",$JOB)
+12 QUIT
+13 ;
ERROR ;
+1 if $DATA(ERROR("DIERR"))
DO ERROR^PSNPPSNU
+2 QUIT
+3 ;
CLASS ;
+1 IF $PIECE(DIA,"^",3)=15
Begin DoDot:1
+2 SET OLDV=$$GET1^DIQ(50.68,$PIECE(DIA,"^"),15,"I")
SET VAGEN=$$GET1^DIQ(50.68,$PIECE(DIA,"^"),.05,"I")
+3 SET VAGENN=$$GET1^DIQ(50.68,$PIECE(DIA,"^"),.05,"E")
+4 ;Does not record class/edits on new VA Products same as NDFRR3 & PSSMIGRR routine
+5 IF OLDV'=""
IF (OLDV'=NEW)
SET ^TMP("PSN PPSN PARSED",$JOB,"PRODS CHANGED CLASSES",$PIECE(DIA,"^"))=OLDV_"^"_NEW_"^"_VAGEN_"^"_VAGENN
End DoDot:1
+6 QUIT
