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