Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSNPPSI3

PSNPPSI3.m

Go to the documentation of this file.
  1. 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
  1. ;Reference to ^DD supported by DBIA #1258
  1. ;
  1. Q
  1. ;
  1. ;This routine parses DATAO records which are edits to existing file entries
  1. DATAO ;
  1. K XFILE,XFLDS
  1. K FDA
  1. S FDA(57.231,CTRLXIEN_","_CTRLIEN_",",6)="DATAO",PSNTMPN="DATAO"
  1. D UPDATE^DIE("","FDA","CTRLIEN")
  1. K FDA
  1. D CTRLFILE^PSNPPSMS(0)
  1. D CTRLSS^PSNPPSMS(0)
  1. D CTRLIEN^PSNPPSMS(0)
  1. S (OJJ,FILE)=0,GROOT=$NA(^TMP("PSN PPSN PARSED",$J,"DATAO"))
  1. ;now load the rest of the data
  1. 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
  1. .S (DIA,NEW)=""
  1. .S DIA=@GROOT1@(JJ) I $G(@GROOT1@(JJ+1))]"" S NEW=@GROOT1@(JJ+1)
  1. .S ^TMP("PSN PPSN PARSED",$J,"AE_PRODUCTS",+DIA)=""
  1. .D CTRLSS^PSNPPSMS($TR(GROOT1,"^")_","_JJ)
  1. .;
  1. .I $G(PSNMULTI) D
  1. ..S (MIENS,MFLDS)="",MIENS=$P(DIA,"^")_",",MFLDS=$P(DIA,"^",3)
  1. ..I MFLDS'=""&($P(NEW,"^")'=MIENS) S PSNMULTI=0,^TMP("PSN PPSN.WPXRF",$J,FILE,OIENS,OFLDS)=""
  1. .S IENS=$P(DIA,"^")_",",FLDS=$P(DIA,"^",3),ROOT=FILE K FDA,IEN
  1. .;
  1. .I FILE=50.68 D UNMATCH^PSNPPSI2
  1. .;
  1. .K RES1
  1. .I '$G(PSNMULTI) D FIELD^DID(FILE,FLDS,"","TYPE","RES1")
  1. .I $G(RES1("TYPE"))="WORD-PROCESSING"!$G(PSNMULTI) D Q
  1. ..I '$G(PSNMULTI) D
  1. ...S MJJ=JJ,OIENS=IENS,OFLDS=FLDS
  1. ...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)
  1. ...;Set 5000 file for word processing fields
  1. ...S PSNWP=$$GET1^DID(FILE,"","","GLOBAL NAME")_$P(DIA,"^")_"," ;"PSNDF(FILE,"_IENS_",1)"
  1. ...D FIELD^DID(FILE,FLDS,"Z","GLOBAL SUBSCRIPT LOCATION","RES2")
  1. ...S RES3="",RES3=$P(RES2("GLOBAL SUBSCRIPT LOCATION"),";")
  1. ...S PSNWP=PSNWP_$S(RES3?1AN.AN:""""_RES3_"""",1:RES3)_")"
  1. ...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)=""
  1. ..;
  1. ..I '$P(DIA,"^",3) S ^TMP("PSN PPSN.WP",$J,FILE,OIENS,OFLDS,MJJ)=$$STRIP^PSNPPSNU(DIA),MJJ=MJJ+1
  1. ..I '$P(NEW,"^",3) S ^TMP("PSN PPSN.WP",$J,FILE,OIENS,OFLDS,MJJ)=$$STRIP^PSNPPSNU(NEW),PSNMULTI=1,MJJ=MJJ+1
  1. ..I $P(NEW,"^",3)'="" S JJ=JJ-1
  1. .;
  1. .S XFILE=FILE
  1. .I FLDS["," D
  1. ..I FILE=50.68,$P($P(DIA,"^",3),",")=43 D MULTIPLE^PSNPPSI2 Q ;new generic multiple .01 field code
  1. ..S LI=$P(DIA,"^",3) F J=1:1:$L(LI,",")-1 S ROOT=+$P(^DD(ROOT,+$P(LI,",",J),0),"^",2)
  1. ..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))=""
  1. ..S XFLDS=$P(FLDS,",",$L(FLDS,",")-1) I $G(XFLDS)'="" S XFILE=+$P(^DD(FILE,XFLDS,0),"^",2) S:$G(XFILE)="" XFILE=FILE
  1. ..S FLDS=$P(FLDS,",",$L(FLDS,","))
  1. .S DA=+IENS
  1. .D CTRLIEN^PSNPPSMS(IENS)
  1. .I FILE=50.68,$P($P(DIA,"^",3),",")=43 Q
  1. .;
  1. .I PSNPS="N",FILE=50.68 D
  1. ..D NDFK^PSNPPSNK
  1. ..I FLDS=31 D
  1. ...K ORDP,ORDN,ERROR
  1. ...S ORDP=$$GET1^DIQ(50.68,+IENS_",",31,"I","ERROR")
  1. ...S ORDN=NEW
  1. ...S ^TMP("PSN PPSN PARSED",$J,"POST_RUN",5000.608,FILE,+IENS,FLDS)=ORDP_"^"_ORDN
  1. ..I $P(DIA,"^",3)="14,.01" S ^TMP("PSN PPSN PARSED",$J,"POST_RUN",5000.509,FILE,IENS,FLDS)=NEW
  1. .;
  1. .D CLASS:FILE=50.68
  1. .;new generic multiple .01 field code
  1. .I FILE=50.68,$P($P(DIA,"^",3),",")=43 Q
  1. .;
  1. .I FILE=50.68,$P(DIA,"^",3)="21" D K FDA
  1. ..K FDA,ERROR
  1. ..D NOW^%DTC
  1. ..S FDA(50.6899,"+1,"_IENS,.01)=$S(NEW="":$P(%,"."),1:NEW),FDA(50.6899,"+1,"_IENS,.02)=$S(NEW="":1,1:0)
  1. ..D UPDATE^DIE("","FDA","","ERROR") D ERROR^PSNPPSNU:$D(ERROR("DIERR")) K FDA
  1. .I PSNPS="N" D
  1. ..I FILE=50.416 D INGRED^PSNPPSNK
  1. ..I FILE=56 D 56^PSNPPSMS(FILE,DIA,NEW,PSNTMPN)
  1. .I PSNPS="N",FILE=50.67&($P(DIA,"^",3)=1) D
  1. .. S ^TMP("PSN PPSN PARSED",$J,"POST_RUN",50.628,FILE,+DIA,1)=NEW
  1. .;****************************************************** 47
  1. .I FILE[50.68,$P(DIA,"^",3)="45,1"!($P(DIA,"^",3)="45,2") K DIE D Q ;**COPAY TIERS
  1. ..K FDA,ERROR
  1. ..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"))
  1. ..K FDA
  1. .;50.606 DOSAGE FORM UNITS
  1. .I FILE[50.606,$P(DIA,"^",3)="8,1" K DIE D Q
  1. ..K FDA,ERROR
  1. ..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"))
  1. ..K FDA
  1. .;50.606 DISPENSE UNITS PER DOSE
  1. .I FILE[50.606,$P(DIA,"^",3)="9,1" K DIE D Q
  1. ..K FDA,ERROR
  1. ..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"))
  1. ..K FDA
  1. .;50
  1. .I $P(DIA,"^",3)="99.991,.01" D K FDA Q
  1. ..K FDA,ERROR
  1. ..S FDA(ROOT,"+"_IENS,FLDS)=NEW D UPDATE^DIE("","FDA","","ERROR") D ERROR K FDA
  1. .;
  1. .I $P(DIA,"^",3)="99.991,.02" D K FDA Q
  1. ..K FDA,ERROR
  1. ..S DA=999999999999 S DA=$O(^PS(FILE,$P(DIA,"^"),"TERMSTATUS",DA),-1) S:DA="" DA=1
  1. ..I FILE=50.6!(FILE=50.68) S DA=999999999999 S DA=$O(^PSNDF(FILE,+$P(DIA,"^"),"TERMSTATUS",DA),-1)
  1. ..S $P(IENS,",",1)=DA,FDA(ROOT,IENS,.02)=NEW D UPDATE^DIE("","FDA","IEN","ERROR") D ERROR K FDA
  1. .;
  1. .;delete sub-field entries if NEW="", means it was removed from the product in PPS-N
  1. .I FILE=50.68&($P(DIA,"^",3)="14,.01")&(NEW="") D Q
  1. ..N DA,DIK,DIAU
  1. ..S DA(1)=$P($P(DIA,"^"),","),ROOT3="^PSNDF(50.68,DA(1),2," ;,ROOT3="^"_XPATH_DA(1)_",2,"
  1. ..S DIK=ROOT3,DA=$P($P(DIA,"^"),",",2) D ^DIK K DIK,DIAU
  1. .;set fields 14,1 and 14,2
  1. .I FILE=50.68&($P(DIA,"^",3)["14,") D Q
  1. ..S DA(1)=$P($P(DIA,"^"),","),XPATH=$P(^DD(ROOT,.01,0),"^",3),ROOT3="^"_XPATH_DA(1)_",2,"
  1. ..K FDA,ERROR S FDA(ROOT,IENS,FLDS)=NEW D UPDATE^DIE("","FDA",DA,"ERROR") D ERROR
  1. .;
  1. .;HAZARDOUS TO DISPOSE FIELD 102 = ZERO; KILL FIELDS 103,104,105
  1. .I FILE=50.68&($P(DIA,"^",3)=102),NEW=0 D
  1. ..S DA=+$P(DIA,"^"),$P(^PSNDF(50.68,DA,"HAZTODIS"),"^",2)="",$P(^PSNDF(50.68,DA,"HAZTODIS"),"^",3)=""
  1. ..K ^PSNDF(50.68,DA,"HAZTODIS2")
  1. .;
  1. .I IENS["," K FDA,ERROR S FDA(ROOT,IENS,FLDS)=NEW D FILE^DIE("","FDA","ERROR") D ERROR K FDA,ERROR Q
  1. .K FDA,ERROR S FDA(FILE,IENS,FLDS)=NEW D FILE^DIE("","FDA","ERROR") D ERROR
  1. .K FDA,ERROR
  1. K XFILE,XFLDS
  1. ;
  1. DATAO2 ;
  1. S JJ=0 F S JJ=$O(^TMP("PSNN",$J,JJ)) Q:'JJ S DA=$P(JJ,",",2),DA(1)=+JJ D
  1. . I '$D(^PSNDF(50.68,DA(1),0)) D ERROR2^PSNPPSNU(PSNTMPN,ROOT,IENS,DA(1),"VA PRODUCT entry does not exist.") Q
  1. . D ING^PSNXREF
  1. S FILE="" F S FILE=$O(^TMP("PSN PPSN.WP",$J,FILE)) Q:FILE="" D
  1. . S IENS="" F S IENS=$O(^TMP("PSN PPSN.WP",$J,FILE,IENS)) Q:IENS="" D
  1. .. S FLDS="" F S FLDS=$O(^TMP("PSN PPSN.WP",$J,FILE,IENS,FLDS)) Q:FLDS="" D
  1. ... K TMP,ERR
  1. ... S JJ=0 F S JJ=$O(^TMP("PSN PPSN.WP",$J,FILE,IENS,FLDS,JJ)) Q:'JJ D
  1. .... S TMP(JJ)=^TMP("PSN PPSN.WP",$J,FILE,IENS,FLDS,JJ)
  1. ... D WP^DIE(FILE,IENS,FLDS,"","TMP","ERR")
  1. K ^TMP("PSN PPSN.WP",$J)
  1. Q
  1. ;
  1. ERROR ;
  1. D ERROR^PSNPPSNU:$D(ERROR("DIERR"))
  1. Q
  1. ;
  1. CLASS ;
  1. I $P(DIA,"^",3)=15 D
  1. .S OLDV=$$GET1^DIQ(50.68,$P(DIA,"^"),15,"I"),VAGEN=$$GET1^DIQ(50.68,$P(DIA,"^"),.05,"I")
  1. .S VAGENN=$$GET1^DIQ(50.68,$P(DIA,"^"),.05,"E")
  1. .;Does not record class/edits on new VA Products same as NDFRR3 & PSSMIGRR routine
  1. .I OLDV'="",(OLDV'=NEW) S ^TMP("PSN PPSN PARSED",$J,"PRODS CHANGED CLASSES",$P(DIA,"^"))=OLDV_"^"_NEW_"^"_VAGEN_"^"_VAGENN
  1. Q