- PSNPPSI2 ;HP/MJE-PPSN update NDF data for parsing DATAN records ; 05 Mar 2014 1:20 PM
- ;;4.0;NATIONAL DRUG FILE;**513**; 30 Oct 98;Build 53
- ;Reference to ^DD supported by DBIA #1258
- ;
- Q
- ;
- ;This routine parses DATAN records which are new entries other than .01 fields to the NDF files
- DATAN ;
- K FDA,^TMP("PSN OLDINGRED",$J),^TMP("PSN ADDINGRED",$J),^TMP("PSN DELINGRED",$J)
- S FDA(57.231,CTRLXIEN_","_CTRLIEN_",",6)="DATAN",PSNTMPN="DATAN"
- D UPDATE^DIE("","FDA","CTRLIEN")
- K FDA,SROOT
- N OFLDS,OIENS,OLDNDF,MIENS,MFLDS,JJJJ,PSNVAPD,OINGRED,XFILE,XFLDS,PSNINGRED
- D CTRLFILE^PSNPPSMS(0)
- D CTRLSS^PSNPPSMS(0)
- D CTRLIEN^PSNPPSMS(0)
- S FILE=0,GROOT=$NA(^TMP("PSN PPSN PARSED",$J,"DATAN"))
- ;load new multiple entries next
- 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)
- .I FILE=50.68 S ^TMP("PSN PPSN PARSED",$J,"AE_PRODUCTS",+DIA)="" S:$P(DIA,"^",3)=.01 ^TMP("PSN PPSN PARSED",$J,"NEW 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,($P(DIA,"^",3)="14,.01") D Q:NEW["DELETE"
- ..I '$D(^TMP("PSN OLDINGRED",$J,$P($P(DIA,"^"),","))) S OINGRED=0 F S OINGRED=$O(^PSNDF(50.68,$P($P(DIA,"^"),","),2,OINGRED)) Q:OINGRED="" S ^TMP("PSN OLDINGRED",$J,$P($P(DIA,"^"),","),OINGRED)=""
- ..D:'$D(^TMP("PSNINGRED",$J,$P($P(DIA,"^"),","))) AIDEL($P($P(DIA,"^"),",")) S ^TMP("PSNINGRED",$J,$P($P(DIA,"^"),","))=""
- .I PSNPS="N",FILE=50.68 D NDFK^PSNPPSNK D
- ..I $P(DIA,"^",3)=31 D
- ...K ORD
- ...S ORD=NEW
- ...S ^TMP("PSN PPSN PARSED",$J,"POST_RUN",5000.608,FILE,IENS,FLDS)=ORD
- .I FILE=50.68 D UNMATCH
- .;
- .I PSNPS="N" D
- ..;I FILE=50.416 D INGRED^PSNPPSNK
- ..I FILE=56 D 56^PSNPPSMS(FILE,DIA,NEW,PSNTMPN)
- .;
- .K RES1,RES2,RES3
- .I '$G(PSNMULTI) D FIELD^DID(FILE,FLDS,"","TYPE","RES1") ;I $G(RES1("TYPE"))'="WORD-PROCESSING" S PSNMULTI=0
- .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
- .;
- .;get multiple info
- .I FLDS["," D
- ..I FILE=50.68,$P($P(DIA,"^",3),",")=43 D MULTIPLE Q
- ..;it should, but
- ..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)_",",^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
- .;
- .;delete copay tiers if needed
- .I ROOT=50.6845&($P($P(DIA,"^"),",",2)=1&($P(DIA,"^",3)="45,.01")) D CPTIERD($P(IENS,",",2)) Q:NEW="DELETED"
- .;
- .I ROOT=50.6068&($P($P(DIA,"^"),",",2)=1&($P(DIA,"^",3)="8,.01")) D DOSFORUD($P(IENS,",",2)) Q:NEW="DELETED" ;dosage form units #50.606
- .I ROOT=50.6069&($P($P(DIA,"^"),",",2)=1&($P(DIA,"^",3)="9,.01")) D DOSFORDD($P(IENS,",",2)) Q:NEW="DELETED" ;dispense units per dose #50.606
- .;
- .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^PSNPPSNU:$D(ERROR("DIERR")) K FDA
- .;
- .;edit single field
- .I $$GET1^DIQ(ROOT,IENS,FLDS)]"" S FDA(ROOT,IENS,.01)=NEW,IEN(DA)=DA D Q
- ..D UPDATE^DIE("","FDA","IEN","") K FDA D CTRLIEN^PSNPPSMS(IENS)
- .;
- .;set new multiple field
- .I $P(DIA,"^",3)["," D Q
- ..K DIC,FDA
- ..;I ROOT'[50.6843 S DA(1)=$P($P(DIA,"^"),",")
- ..S DA(1)=$P($P(DIA,"^"),","),DIC=$$ROOT^DILFD(ROOT,IENS,,1)
- ..S X=NEW,DIC(0)="L",DIC("DR")="S Y=0"
- ..I ROOT[50.6068!(ROOT[50.6069) S (DA,DINUM)=$P($P(DIA,"^"),",",2) ;this is in here until PPS-N fixes the IENS
- ..I ROOT[50.6845!(ROOT[50.6814) S DA=$P($P(DIA,"^"),",",2)
- ..I ROOT["50.68"&($P(DIA,"^",3)="14,.01"!($P(DIA,"^",3)="16,.01")!($P(DIA,"^",3)="45,.01")) S DINUM=DA
- ..K DD,DO D FILE^DICN I 'Y D ERROR2^PSNPPSNU(PSNTMPN,ROOT,IENS,DA,"Error setting new multiple entry")
- ..I ROOT[50.6845,(PSNATYP="N") D CPTIER^PSNPPSNK(DIA)
- .;
- .I $P(DIA,"^",3)="99.991,.02" D K FDA,ERROR Q
- ..S DA=999999999999 S DA=$O(^PS(FILE,+$P(DIA,"^"),"TERMSTATUS",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^PSNPPSNU:$D(ERROR("DIERR")) K FDA
- .;
- .;set new single field
- .K DIC,FDA
- .S DINUM=DA,X=NEW,DIC=ROOT,DIC(0)="L",DIC("DR")="S Y=0" K DD,DO D FILE^DICN I 'Y D ERROR2^PSNPPSNU(PSNTMPN,ROOT,IENS,DA,"Error new single field")
- .D CTRLIEN^PSNPPSMS(IENS)
- ;
- DATAN2 ;word processing fields
- S ERROR=0
- 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
- .;50.68 ADDED INGREDIENT 5000.508
- ;S ^TMP("PSN OLDINGRED",$J,PSNVAPD,CNT1)=""
- I PSNPS="N" S (PSNINGRED,PSNVAPD)="" D
- .;if ingredient remains on the product, then it wasn't deleted
- .F S PSNVAPD=$O(^TMP("PSN OLDINGRED",$J,PSNVAPD)) Q:PSNVAPD="" F S PSNINGRED=$O(^TMP("PSN OLDINGRED",$J,PSNVAPD,PSNINGRED)) Q:PSNINGRED="" D
- ..I '$D(^PSNDF(50.68,PSNVAPD,2,PSNINGRED,0)) S ^TMP("PSN DELINGRED",$J,PSNINGRED)=""
- .;if the ingredient was not one of the old ingredients then it was added
- .F S PSNVAPD=$O(^TMP("PSN OLDINGRED",$J,PSNVAPD)) Q:PSNVAPD="" S PSNINGRED=0 F S PSNINGRED=$O(^PSNDF(50.68,PSNVAPD,2,PSNINGRED)) Q:PSNINGRED="" D
- ..I '$D(^TMP("PSN OLDINGRED",$J,PSNVAPD,PSNINGRED)) S ^TMP("PSN ADDINGRED",$J,PSNINGRED)=""
- .;I PSNPS="N" S X=+$P(DIA,"^") I '$D(^NDFK(5000.508,"B",X)) S DIC=5000.508,DIC(0)="LMXZ" D FILE^DICN
- ;
- 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)
- ;
- D DATAO^PSNPPSI3
- Q
- ;
- CPTIERD(PSNVAPN) ;copay tiers deleted
- N COPAYACT
- S CNT=0 F S CNT=$O(^PSNDF(50.68,PSNVAPN,10,CNT)) Q:CNT="" D
- . S DIK="^PSNDF(50.68,"_PSNVAPN_",10,",DA=CNT,DA(1)=PSNVAPN
- . D ^DIK
- S COPAYACT=0
- I PSNATYP="N" D COPNDFK
- Q
- ;
- COPNDFK ; define NDFK file 5000.93
- N X,DIC,DIE,DR,NDFKSEQ,PRIEN,NAME S NDFKSEQ="",PRIEN=PSNVAPN
- I '$D(^NDFK(5000.93,0)) S ^NDFK(5000.93,0)="COPAY TIERS SETTINGS CHANGES^5000.93P^0^0"
- S NAME=$$GET1^DIQ(50.68,PRIEN,.01,"E")
- S X=NAME,DIC=5000.93,DIC(0)="LMXZ" D ^DIC
- S DIE=DIC,DA=+Y K DIC
- S DR=".01///^S X=PRIEN;1///^S X="_COPAYACT ;Copay action - 0 = delete or 1 = add/edit
- D ^DIE
- Q
- ;
- DOSFORUD(PSNVAPN) ;dosage forms units deleted
- N DOSFORU
- S CNT=0 F S CNT=$O(^PS(50.606,PSNVAPN,"UNIT",CNT)) Q:CNT="" D
- . S DIK="^PS(50.606,"_PSNVAPN_","_"""UNIT"""_",",DA=CNT,DA(1)=PSNVAPN
- . D ^DIK
- S DOSFORU=0
- Q
- ;
- DOSFORDD(PSNVAPN) ;dispense units per dose deleted
- N DOSFORU
- S CNT=0 F S CNT=$O(^PS(50.606,PSNVAPN,"DUPD",CNT)) Q:CNT="" D
- . S DIK="^PS(50.606,"_PSNVAPN_","_"""DUPD"""_",",DA=CNT,DA(1)=PSNVAPN
- . D ^DIK
- S DOSFORU=0
- Q
- ;
- MULTIPLE ;There should only be one RxNorm entry and one RXCUI
- N DA,SROOT,MROOT,MLTCNT,DIC,DINUM,X,Y,DINUM,VAPRIEN,SS1,SS2,SS3,DLAYGO
- S LI=$P(DIA,"^",3),SROOT=ROOT,ROOT=50.68,MLTCNT="",VAPRIEN=$P($P(DIA,"^"),",")
- ;handles a multiple and a multiple within a multiple
- I FILE=50.68,$P(DIA,"^",3)="43,.01",(NEW["DELETE"!(NEW="")) D RXNORMD1(VAPRIEN) Q
- I FILE=50.68,$P(DIA,"^",3)="43,.02,.01",(NEW["DELETE"!(NEW="")) D RXNORMD1(VAPRIEN) Q
- I PSNTMPN="DATAN" D ;DATAN records are new entries and should not be already defined
- .I FILE=50.68,$P(DIA,"^",3)="43,.01" D:$D(^PSNDF(50.68,VAPRIEN,11,0)) RXNORMD1(VAPRIEN) Q
- .I FILE=50.68,$P(DIA,"^",3)="43,.02,.01" D
- ..S SS1="",SS1=$O(^PSNDF(50.68,VAPRIEN,11,"B","RxNorm",SS1))
- ..Q:SS1=""
- ..S (SS3,SS2)=0 F S SS2=$O(^PSNDF(50.68,VAPRIEN,11,SS1,1,SS2)) Q:'SS2 S SS3=1
- ..Q:'SS3
- ..D RXNORMD2(VAPRIEN)
- ;ROOT=top of file, and then sets root to the multiple root
- F J=1:1:$L(LI,",")-1 S ROOT=+$P(^DD(ROOT,+$P(LI,",",J),0),"^",2)
- S MROOT=ROOT
- S LI=$P(DIA,"^"),IENS="" F J=$L(LI,","):-1:1 S IENS=IENS_$P(LI,",",J)_",",^TMP("PSN PPSN PARSED",$J,"AE_PRODUCTS",$P(LI,",",J))=""
- F J=1:1 Q:$P(LI,",",J)="" S MLTCNT=MLTCNT+1
- S XFLDS=$P(FLDS,",",$L(FLDS,","))
- I PSNTMPN="DATAO" D EDTMULT Q
- I MLTCNT=2 S FLDS=$P(FLDS,",",MLTCNT) D
- .K DIC,DA S DA(1)=VAPRIEN,X=VAPRIEN,DIC="^PSNDF(50.68,"_VAPRIEN_",11,",DIC(0)="ZQL",DLAYGO=50.6843,X=NEW D ^DIC
- I MLTCNT>2 S FLDS=$P(FLDS,",",MLTCNT-1) D
- .K DIC,DA S DA(1)=VAPRIEN,X=VAPRIEN,DIC="^PSNDF(50.68,"_VAPRIEN_",11,",DIC(0)="ZQ",X="RxNorm" D ^DIC
- .I +$G(Y) S DA(1)=+Y,DA(2)=VAPRIEN
- .I DA(1)="" D ERROR2^PSNPPSNU(PSNTMPN,MROOT,IENS,DA,"Error setting new multiple entry - top level multiple is not defined")
- .K DIC,Y S X=DA(1),DIC="^PSNDF(50.68,"_VAPRIEN_",11,"_DA(1)_",1,",DIC(0)="ZQL",DLAYGO=50.68431,X=NEW D ^DIC
- .I Y=-1!(+Y="") D ERROR2^PSNPPSNU(PSNTMPN,MROOT,IENS,DA,"Error setting new multiple entry - top level multiple is not defined") Q
- .S DA=+Y,DIE=DIC K DIC S DR=".01///"_NEW D ^DIE K DIE,DR,DA,Y
- Q
- ;
- EDTMULT ;edit existing multiple entry other than .01 field
- K DIC,DA S DA(1)=VAPRIEN,X=VAPRIEN,DIC="^PSNDF(50.68,"_VAPRIEN_",11,",DIC(0)="ZQ",X="RxNorm" D ^DIC
- I Y=-1!(+Y="") D ERROR2^PSNPPSNU(PSNTMPN,MROOT,IENS,DA,"Error editing RxNorm multiple - top level multiple is not defined") Q
- S DA(1)=+Y,DA(2)=VAPRIEN
- S DA=0,DA=$O(^PSNDF(50.68,6173,11,3,""),-1)
- I DA=0!(DA="") D ERROR2^PSNPPSNU(PSNTMPN,MROOT,IENS,DA,"Error editing RxNorm multiple - multiple is not defined")
- S DIE=DIC,IENS=DA_","_DA(1)_","_DA(2)_","
- S XPATH=$P(^DD(ROOT,.01,0),"^",3),ROOT3="^"_XPATH_DA(1)_",2,"
- K FDA,ERROR S FDA(ROOT,IENS,XFLDS)=NEW D UPDATE^DIE("","FDA",DA,"ERROR")
- S ROOT=SROOT
- Q
- ;
- RXNORMD1(PSNVAPN) ;RxNorm deleted
- N CNT,CNT2,DIK,DA,X
- S CNT=0 F S CNT=$O(^PSNDF(50.68,PSNVAPN,11,CNT)) Q:CNT'?1N.N D
- .S X="",X=$G(^PSNDF(50.68,PSNVAPN,11,CNT,0))
- .Q:X=""
- .Q:X'="RxNorm"
- .S DIK="^PSNDF(50.68,"_PSNVAPN_",11,",DA=CNT,DA(1)=PSNVAPN
- .D ^DIK
- Q
- ;
- RXNORMD2(PSNVAPN) ;RxNorm deleted
- N CNT,CNT2,DIK,DA,X,OVAL
- S (CNT2,CNT)=0 F S CNT=$O(^PSNDF(50.68,PSNVAPN,11,CNT)) Q:CNT'?1N.N F S CNT2=$O(^PSNDF(50.68,PSNVAPN,11,CNT,1,CNT2)) Q:CNT2'?1N.N D
- .S X="",X=$G(^PSNDF(50.68,PSNVAPN,11,CNT,1,CNT2,0))
- .Q:X=""
- .S OVAL=X,X=NEW
- .S DIK="^PSNDF(50.68,"_PSNVAPN_",11,"_CNT_",1,",DA=CNT2,DA(1)=CNT,DA(2)=PSNVAPN
- .D ^DIK
- .K ^PSNDF(50.68,PSNVAPN,11,CNT,CNT2,"B",OVAL)
- Q
- ;
- UNMATCH ;DRUGS TO UNMATCH
- N DIAFLD,OLDGEN
- S (DIAFLD,OLDGEN)="",DIAFLD=$P(DIA,"^",3)
- I DIAFLD=.05!(DIAFLD=1)!(DIAFLD=2)!(DIAFLD=3)!(DIAFLD=5)!(DIAFLD=6)!(DIAFLD=8) D
- .Q:$D(^TMP("PSN PPSN PARSED",$J,"NEW PRODUCTS",+DIA))
- .S ^TMP("PSN PPSN PARSED",$J,"PRODUCTS TO UNMATCH",$P(DIA,"^"))=""
- .D SETPROD
- Q
- ;
- SETPROD ;
- Q:PSNPS'="N"
- Q:$D(^NDFK(5000.2,"B",$P(DIA,"^")))
- S (DINUM,X)=$P(DIA,"^"),DIC=5000.2,DIC(0)="LMXZ" D FILE^DICN
- Q
- ;
- AIDEL(PSNVAPD) ; active ingredients deleted
- N CNT1,DA,DINUM,X
- S CNT1=0 F S CNT1=$O(^PSNDF(50.68,PSNVAPD,2,CNT1)) Q:CNT1="" D
- .S DIK="^PSNDF(50.68,"_PSNVAPD_",2,",DA=CNT1,DA(1)=PSNVAPD D ^DIK
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSNPPSI2 12578 printed Feb 18, 2025@23:50:58 Page 2
- PSNPPSI2 ;HP/MJE-PPSN update NDF data for parsing DATAN records ; 05 Mar 2014 1:20 PM
- +1 ;;4.0;NATIONAL DRUG FILE;**513**; 30 Oct 98;Build 53
- +2 ;Reference to ^DD supported by DBIA #1258
- +3 ;
- +4 QUIT
- +5 ;
- +6 ;This routine parses DATAN records which are new entries other than .01 fields to the NDF files
- DATAN ;
- +1 KILL FDA,^TMP("PSN OLDINGRED",$JOB),^TMP("PSN ADDINGRED",$JOB),^TMP("PSN DELINGRED",$JOB)
- +2 SET FDA(57.231,CTRLXIEN_","_CTRLIEN_",",6)="DATAN"
- SET PSNTMPN="DATAN"
- +3 DO UPDATE^DIE("","FDA","CTRLIEN")
- +4 KILL FDA,SROOT
- +5 NEW OFLDS,OIENS,OLDNDF,MIENS,MFLDS,JJJJ,PSNVAPD,OINGRED,XFILE,XFLDS,PSNINGRED
- +6 DO CTRLFILE^PSNPPSMS(0)
- +7 DO CTRLSS^PSNPPSMS(0)
- +8 DO CTRLIEN^PSNPPSMS(0)
- +9 SET FILE=0
- SET GROOT=$NAME(^TMP("PSN PPSN PARSED",$JOB,"DATAN"))
- +10 ;load new multiple entries next
- +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 IF FILE=50.68
- SET ^TMP("PSN PPSN PARSED",$JOB,"AE_PRODUCTS",+DIA)=""
- if $PIECE(DIA,"^",3)=.01
- SET ^TMP("PSN PPSN PARSED",$JOB,"NEW PRODUCTS",+DIA)=""
- +15 DO CTRLSS^PSNPPSMS($TRANSLATE(GROOT1,"^")_","_JJ)
- +16 IF $GET(PSNMULTI)
- Begin DoDot:2
- +17 SET (MIENS,MFLDS)=""
- SET MIENS=$PIECE(DIA,"^")_","
- SET MFLDS=$PIECE(DIA,"^",3)
- +18 IF MFLDS'=""&($PIECE(NEW,"^")'=MIENS)
- SET PSNMULTI=0
- SET ^TMP("PSN PPSN.WPXRF",$JOB,FILE,OIENS,OFLDS)=""
- End DoDot:2
- +19 SET IENS=$PIECE(DIA,"^")_","
- SET FLDS=$PIECE(DIA,"^",3)
- SET ROOT=FILE
- KILL FDA,IEN
- +20 IF FILE=50.68
- IF ($PIECE(DIA,"^",3)="14,.01")
- Begin DoDot:2
- +21 IF '$DATA(^TMP("PSN OLDINGRED",$JOB,$PIECE($PIECE(DIA,"^"),",")))
- SET OINGRED=0
- FOR
- SET OINGRED=$ORDER(^PSNDF(50.68,$PIECE($PIECE(DIA,"^"),","),2,OINGRED))
- if OINGRED=""
- QUIT
- SET ^TMP("PSN OLDINGRED",$JOB,$PIECE($PIECE(DIA,"^"),","),OINGRED)=""
- +22 if '$DATA(^TMP("PSNINGRED",$JOB,$PIECE($PIECE(DIA,"^"),",")))
- DO AIDEL($PIECE($PIECE(DIA,"^"),","))
- SET ^TMP("PSNINGRED",$JOB,$PIECE($PIECE(DIA,"^"),","))=""
- End DoDot:2
- if NEW["DELETE"
- QUIT
- +23 IF PSNPS="N"
- IF FILE=50.68
- DO NDFK^PSNPPSNK
- Begin DoDot:2
- +24 IF $PIECE(DIA,"^",3)=31
- Begin DoDot:3
- +25 KILL ORD
- +26 SET ORD=NEW
- +27 SET ^TMP("PSN PPSN PARSED",$JOB,"POST_RUN",5000.608,FILE,IENS,FLDS)=ORD
- End DoDot:3
- End DoDot:2
- +28 IF FILE=50.68
- DO UNMATCH
- +29 ;
- +30 IF PSNPS="N"
- Begin DoDot:2
- +31 ;I FILE=50.416 D INGRED^PSNPPSNK
- +32 IF FILE=56
- DO 56^PSNPPSMS(FILE,DIA,NEW,PSNTMPN)
- End DoDot:2
- +33 ;
- +34 KILL RES1,RES2,RES3
- +35 ;I $G(RES1("TYPE"))'="WORD-PROCESSING" S PSNMULTI=0
- IF '$GET(PSNMULTI)
- DO FIELD^DID(FILE,FLDS,"","TYPE","RES1")
- +36 IF $GET(RES1("TYPE"))="WORD-PROCESSING"!$GET(PSNMULTI)
- Begin DoDot:2
- +37 IF '$GET(PSNMULTI)
- Begin DoDot:3
- +38 SET MJJ=JJ
- SET OIENS=IENS
- SET OFLDS=FLDS
- +39 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)
- +40 ;Set 5000 file for word processing fields
- +41 ;"PSNDF(FILE,"_IENS_",1)"
- SET PSNWP=$$GET1^DID(FILE,"","","GLOBAL NAME")_$PIECE(DIA,"^")_","
- +42 DO FIELD^DID(FILE,FLDS,"Z","GLOBAL SUBSCRIPT LOCATION","RES2")
- +43 SET RES3=""
- SET RES3=$PIECE(RES2("GLOBAL SUBSCRIPT LOCATION"),";")
- +44 SET PSNWP=PSNWP_$SELECT(RES3?1AN.AN:""""_RES3_"""",1:RES3)_")"
- +45 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
- +46 ;
- +47 IF '$PIECE(DIA,"^",3)
- SET ^TMP("PSN PPSN.WP",$JOB,FILE,OIENS,OFLDS,MJJ)=$$STRIP^PSNPPSNU(DIA)
- SET MJJ=MJJ+1
- +48 IF '$PIECE(NEW,"^",3)
- SET ^TMP("PSN PPSN.WP",$JOB,FILE,OIENS,OFLDS,MJJ)=$$STRIP^PSNPPSNU(NEW)
- SET PSNMULTI=1
- SET MJJ=MJJ+1
- +49 IF $PIECE(NEW,"^",3)'=""
- SET JJ=JJ-1
- End DoDot:2
- QUIT
- +50 ;
- +51 ;get multiple info
- +52 IF FLDS[","
- Begin DoDot:2
- +53 IF FILE=50.68
- IF $PIECE($PIECE(DIA,"^",3),",")=43
- DO MULTIPLE
- QUIT
- +54 ;it should, but
- +55 SET LI=$PIECE(DIA,"^",3)
- FOR J=1:1:$LENGTH(LI,",")-1
- SET ROOT=+$PIECE(^DD(ROOT,+$PIECE(LI,",",J),0),"^",2)
- +56 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))=""
- +57 SET XFLDS=$PIECE(FLDS,",",$LENGTH(FLDS,",")-1)
- IF $GET(XFLDS)'=""
- SET XFILE=+$PIECE(^DD(FILE,XFLDS,0),"^",2)
- if $GET(XFILE)=""
- SET XFILE=FILE
- +58 SET FLDS=$PIECE(FLDS,",",$LENGTH(FLDS,","))
- End DoDot:2
- +59 SET DA=+IENS
- +60 DO CTRLIEN^PSNPPSMS(IENS)
- +61 ;
- +62 IF FILE=50.68
- IF $PIECE($PIECE(DIA,"^",3),",")=43
- QUIT
- +63 ;
- +64 ;delete copay tiers if needed
- +65 IF ROOT=50.6845&($PIECE($PIECE(DIA,"^"),",",2)=1&($PIECE(DIA,"^",3)="45,.01"))
- DO CPTIERD($PIECE(IENS,",",2))
- if NEW="DELETED"
- QUIT
- +66 ;
- +67 ;dosage form units #50.606
- IF ROOT=50.6068&($PIECE($PIECE(DIA,"^"),",",2)=1&($PIECE(DIA,"^",3)="8,.01"))
- DO DOSFORUD($PIECE(IENS,",",2))
- if NEW="DELETED"
- QUIT
- +68 ;dispense units per dose #50.606
- IF ROOT=50.6069&($PIECE($PIECE(DIA,"^"),",",2)=1&($PIECE(DIA,"^",3)="9,.01"))
- DO DOSFORDD($PIECE(IENS,",",2))
- if NEW="DELETED"
- QUIT
- +69 ;
- +70 IF $PIECE(DIA,"^",3)="99.991,.01"
- Begin DoDot:2
- +71 KILL FDA,ERROR
- +72 SET FDA(ROOT,"+"_IENS,FLDS)=NEW
- DO UPDATE^DIE("","FDA","","ERROR")
- if $DATA(ERROR("DIERR"))
- DO ERROR^PSNPPSNU
- KILL FDA
- End DoDot:2
- KILL FDA
- QUIT
- +73 ;
- +74 ;edit single field
- +75 IF $$GET1^DIQ(ROOT,IENS,FLDS)]""
- SET FDA(ROOT,IENS,.01)=NEW
- SET IEN(DA)=DA
- Begin DoDot:2
- +76 DO UPDATE^DIE("","FDA","IEN","")
- KILL FDA
- DO CTRLIEN^PSNPPSMS(IENS)
- End DoDot:2
- QUIT
- +77 ;
- +78 ;set new multiple field
- +79 IF $PIECE(DIA,"^",3)[","
- Begin DoDot:2
- +80 KILL DIC,FDA
- +81 ;I ROOT'[50.6843 S DA(1)=$P($P(DIA,"^"),",")
- +82 SET DA(1)=$PIECE($PIECE(DIA,"^"),",")
- SET DIC=$$ROOT^DILFD(ROOT,IENS,,1)
- +83 SET X=NEW
- SET DIC(0)="L"
- SET DIC("DR")="S Y=0"
- +84 ;this is in here until PPS-N fixes the IENS
- IF ROOT[50.6068!(ROOT[50.6069)
- SET (DA,DINUM)=$PIECE($PIECE(DIA,"^"),",",2)
- +85 IF ROOT[50.6845!(ROOT[50.6814)
- SET DA=$PIECE($PIECE(DIA,"^"),",",2)
- +86 IF ROOT["50.68"&($PIECE(DIA,"^",3)="14,.01"!($PIECE(DIA,"^",3)="16,.01")!($PIECE(DIA,"^",3)="45,.01"))
- SET DINUM=DA
- +87 KILL DD,DO
- DO FILE^DICN
- IF 'Y
- DO ERROR2^PSNPPSNU(PSNTMPN,ROOT,IENS,DA,"Error setting new multiple entry")
- +88 IF ROOT[50.6845
- IF (PSNATYP="N")
- DO CPTIER^PSNPPSNK(DIA)
- End DoDot:2
- QUIT
- +89 ;
- +90 IF $PIECE(DIA,"^",3)="99.991,.02"
- Begin DoDot:2
- +91 SET DA=999999999999
- SET DA=$ORDER(^PS(FILE,+$PIECE(DIA,"^"),"TERMSTATUS",DA),-1)
- +92 IF FILE=50.6!(FILE=50.68)
- SET DA=999999999999
- SET DA=$ORDER(^PSNDF(FILE,+$PIECE(DIA,"^"),"TERMSTATUS",DA),-1)
- +93 SET $PIECE(IENS,",",1)=DA
- SET FDA(ROOT,IENS,.02)=NEW
- DO UPDATE^DIE("","FDA","IEN","ERROR")
- if $DATA(ERROR("DIERR"))
- DO ERROR^PSNPPSNU
- KILL FDA
- End DoDot:2
- KILL FDA,ERROR
- QUIT
- +94 ;
- +95 ;set new single field
- +96 KILL DIC,FDA
- +97 SET DINUM=DA
- SET X=NEW
- SET DIC=ROOT
- SET DIC(0)="L"
- SET DIC("DR")="S Y=0"
- KILL DD,DO
- DO FILE^DICN
- IF 'Y
- DO ERROR2^PSNPPSNU(PSNTMPN,ROOT,IENS,DA,"Error new single field")
- +98 DO CTRLIEN^PSNPPSMS(IENS)
- End DoDot:1
- +99 ;
- DATAN2 ;word processing fields
- +1 SET ERROR=0
- +2 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
- +3 IF '$DATA(^PSNDF(50.68,DA(1),0))
- DO ERROR2^PSNPPSNU(PSNTMPN,ROOT,IENS,DA(1),"VA PRODUCT entry does not exist.")
- QUIT
- +4 DO ING^PSNXREF
- +5 ;50.68 ADDED INGREDIENT 5000.508
- End DoDot:1
- +6 ;S ^TMP("PSN OLDINGRED",$J,PSNVAPD,CNT1)=""
- +7 IF PSNPS="N"
- SET (PSNINGRED,PSNVAPD)=""
- Begin DoDot:1
- +8 ;if ingredient remains on the product, then it wasn't deleted
- +9 FOR
- SET PSNVAPD=$ORDER(^TMP("PSN OLDINGRED",$JOB,PSNVAPD))
- if PSNVAPD=""
- QUIT
- FOR
- SET PSNINGRED=$ORDER(^TMP("PSN OLDINGRED",$JOB,PSNVAPD,PSNINGRED))
- if PSNINGRED=""
- QUIT
- Begin DoDot:2
- +10 IF '$DATA(^PSNDF(50.68,PSNVAPD,2,PSNINGRED,0))
- SET ^TMP("PSN DELINGRED",$JOB,PSNINGRED)=""
- End DoDot:2
- +11 ;if the ingredient was not one of the old ingredients then it was added
- +12 FOR
- SET PSNVAPD=$ORDER(^TMP("PSN OLDINGRED",$JOB,PSNVAPD))
- if PSNVAPD=""
- QUIT
- SET PSNINGRED=0
- FOR
- SET PSNINGRED=$ORDER(^PSNDF(50.68,PSNVAPD,2,PSNINGRED))
- if PSNINGRED=""
- QUIT
- Begin DoDot:2
- +13 IF '$DATA(^TMP("PSN OLDINGRED",$JOB,PSNVAPD,PSNINGRED))
- SET ^TMP("PSN ADDINGRED",$JOB,PSNINGRED)=""
- End DoDot:2
- +14 ;I PSNPS="N" S X=+$P(DIA,"^") I '$D(^NDFK(5000.508,"B",X)) S DIC=5000.508,DIC(0)="LMXZ" D FILE^DICN
- End DoDot:1
- +15 ;
- +16 SET FILE=""
- FOR
- SET FILE=$ORDER(^TMP("PSN PPSN.WP",$JOB,FILE))
- if FILE=""
- QUIT
- Begin DoDot:1
- +17 SET IENS=""
- FOR
- SET IENS=$ORDER(^TMP("PSN PPSN.WP",$JOB,FILE,IENS))
- if IENS=""
- QUIT
- Begin DoDot:2
- +18 SET FLDS=""
- FOR
- SET FLDS=$ORDER(^TMP("PSN PPSN.WP",$JOB,FILE,IENS,FLDS))
- if FLDS=""
- QUIT
- Begin DoDot:3
- +19 KILL TMP,ERR
- +20 SET JJ=0
- FOR
- SET JJ=$ORDER(^TMP("PSN PPSN.WP",$JOB,FILE,IENS,FLDS,JJ))
- if 'JJ
- QUIT
- Begin DoDot:4
- +21 SET TMP(JJ)=^TMP("PSN PPSN.WP",$JOB,FILE,IENS,FLDS,JJ)
- End DoDot:4
- +22 DO WP^DIE(FILE,IENS,FLDS,"","TMP","ERR")
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +23 KILL ^TMP("PSN PPSN.WP",$JOB)
- +24 ;
- +25 DO DATAO^PSNPPSI3
- +26 QUIT
- +27 ;
- CPTIERD(PSNVAPN) ;copay tiers deleted
- +1 NEW COPAYACT
- +2 SET CNT=0
- FOR
- SET CNT=$ORDER(^PSNDF(50.68,PSNVAPN,10,CNT))
- if CNT=""
- QUIT
- Begin DoDot:1
- +3 SET DIK="^PSNDF(50.68,"_PSNVAPN_",10,"
- SET DA=CNT
- SET DA(1)=PSNVAPN
- +4 DO ^DIK
- End DoDot:1
- +5 SET COPAYACT=0
- +6 IF PSNATYP="N"
- DO COPNDFK
- +7 QUIT
- +8 ;
- COPNDFK ; define NDFK file 5000.93
- +1 NEW X,DIC,DIE,DR,NDFKSEQ,PRIEN,NAME
- SET NDFKSEQ=""
- SET PRIEN=PSNVAPN
- +2 IF '$DATA(^NDFK(5000.93,0))
- SET ^NDFK(5000.93,0)="COPAY TIERS SETTINGS CHANGES^5000.93P^0^0"
- +3 SET NAME=$$GET1^DIQ(50.68,PRIEN,.01,"E")
- +4 SET X=NAME
- SET DIC=5000.93
- SET DIC(0)="LMXZ"
- DO ^DIC
- +5 SET DIE=DIC
- SET DA=+Y
- KILL DIC
- +6 ;Copay action - 0 = delete or 1 = add/edit
- SET DR=".01///^S X=PRIEN;1///^S X="_COPAYACT
- +7 DO ^DIE
- +8 QUIT
- +9 ;
- DOSFORUD(PSNVAPN) ;dosage forms units deleted
- +1 NEW DOSFORU
- +2 SET CNT=0
- FOR
- SET CNT=$ORDER(^PS(50.606,PSNVAPN,"UNIT",CNT))
- if CNT=""
- QUIT
- Begin DoDot:1
- +3 SET DIK="^PS(50.606,"_PSNVAPN_","_"""UNIT"""_","
- SET DA=CNT
- SET DA(1)=PSNVAPN
- +4 DO ^DIK
- End DoDot:1
- +5 SET DOSFORU=0
- +6 QUIT
- +7 ;
- DOSFORDD(PSNVAPN) ;dispense units per dose deleted
- +1 NEW DOSFORU
- +2 SET CNT=0
- FOR
- SET CNT=$ORDER(^PS(50.606,PSNVAPN,"DUPD",CNT))
- if CNT=""
- QUIT
- Begin DoDot:1
- +3 SET DIK="^PS(50.606,"_PSNVAPN_","_"""DUPD"""_","
- SET DA=CNT
- SET DA(1)=PSNVAPN
- +4 DO ^DIK
- End DoDot:1
- +5 SET DOSFORU=0
- +6 QUIT
- +7 ;
- MULTIPLE ;There should only be one RxNorm entry and one RXCUI
- +1 NEW DA,SROOT,MROOT,MLTCNT,DIC,DINUM,X,Y,DINUM,VAPRIEN,SS1,SS2,SS3,DLAYGO
- +2 SET LI=$PIECE(DIA,"^",3)
- SET SROOT=ROOT
- SET ROOT=50.68
- SET MLTCNT=""
- SET VAPRIEN=$PIECE($PIECE(DIA,"^"),",")
- +3 ;handles a multiple and a multiple within a multiple
- +4 IF FILE=50.68
- IF $PIECE(DIA,"^",3)="43,.01"
- IF (NEW["DELETE"!(NEW=""))
- DO RXNORMD1(VAPRIEN)
- QUIT
- +5 IF FILE=50.68
- IF $PIECE(DIA,"^",3)="43,.02,.01"
- IF (NEW["DELETE"!(NEW=""))
- DO RXNORMD1(VAPRIEN)
- QUIT
- +6 ;DATAN records are new entries and should not be already defined
- IF PSNTMPN="DATAN"
- Begin DoDot:1
- +7 IF FILE=50.68
- IF $PIECE(DIA,"^",3)="43,.01"
- if $DATA(^PSNDF(50.68,VAPRIEN,11,0))
- DO RXNORMD1(VAPRIEN)
- QUIT
- +8 IF FILE=50.68
- IF $PIECE(DIA,"^",3)="43,.02,.01"
- Begin DoDot:2
- +9 SET SS1=""
- SET SS1=$ORDER(^PSNDF(50.68,VAPRIEN,11,"B","RxNorm",SS1))
- +10 if SS1=""
- QUIT
- +11 SET (SS3,SS2)=0
- FOR
- SET SS2=$ORDER(^PSNDF(50.68,VAPRIEN,11,SS1,1,SS2))
- if 'SS2
- QUIT
- SET SS3=1
- +12 if 'SS3
- QUIT
- +13 DO RXNORMD2(VAPRIEN)
- End DoDot:2
- End DoDot:1
- +14 ;ROOT=top of file, and then sets root to the multiple root
- +15 FOR J=1:1:$LENGTH(LI,",")-1
- SET ROOT=+$PIECE(^DD(ROOT,+$PIECE(LI,",",J),0),"^",2)
- +16 SET MROOT=ROOT
- +17 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))=""
- +18 FOR J=1:1
- if $PIECE(LI,",",J)=""
- QUIT
- SET MLTCNT=MLTCNT+1
- +19 SET XFLDS=$PIECE(FLDS,",",$LENGTH(FLDS,","))
- +20 IF PSNTMPN="DATAO"
- DO EDTMULT
- QUIT
- +21 IF MLTCNT=2
- SET FLDS=$PIECE(FLDS,",",MLTCNT)
- Begin DoDot:1
- +22 KILL DIC,DA
- SET DA(1)=VAPRIEN
- SET X=VAPRIEN
- SET DIC="^PSNDF(50.68,"_VAPRIEN_",11,"
- SET DIC(0)="ZQL"
- SET DLAYGO=50.6843
- SET X=NEW
- DO ^DIC
- End DoDot:1
- +23 IF MLTCNT>2
- SET FLDS=$PIECE(FLDS,",",MLTCNT-1)
- Begin DoDot:1
- +24 KILL DIC,DA
- SET DA(1)=VAPRIEN
- SET X=VAPRIEN
- SET DIC="^PSNDF(50.68,"_VAPRIEN_",11,"
- SET DIC(0)="ZQ"
- SET X="RxNorm"
- DO ^DIC
- +25 IF +$GET(Y)
- SET DA(1)=+Y
- SET DA(2)=VAPRIEN
- +26 IF DA(1)=""
- DO ERROR2^PSNPPSNU(PSNTMPN,MROOT,IENS,DA,"Error setting new multiple entry - top level multiple is not defined")
- +27 KILL DIC,Y
- SET X=DA(1)
- SET DIC="^PSNDF(50.68,"_VAPRIEN_",11,"_DA(1)_",1,"
- SET DIC(0)="ZQL"
- SET DLAYGO=50.68431
- SET X=NEW
- DO ^DIC
- +28 IF Y=-1!(+Y="")
- DO ERROR2^PSNPPSNU(PSNTMPN,MROOT,IENS,DA,"Error setting new multiple entry - top level multiple is not defined")
- QUIT
- +29 SET DA=+Y
- SET DIE=DIC
- KILL DIC
- SET DR=".01///"_NEW
- DO ^DIE
- KILL DIE,DR,DA,Y
- End DoDot:1
- +30 QUIT
- +31 ;
- EDTMULT ;edit existing multiple entry other than .01 field
- +1 KILL DIC,DA
- SET DA(1)=VAPRIEN
- SET X=VAPRIEN
- SET DIC="^PSNDF(50.68,"_VAPRIEN_",11,"
- SET DIC(0)="ZQ"
- SET X="RxNorm"
- DO ^DIC
- +2 IF Y=-1!(+Y="")
- DO ERROR2^PSNPPSNU(PSNTMPN,MROOT,IENS,DA,"Error editing RxNorm multiple - top level multiple is not defined")
- QUIT
- +3 SET DA(1)=+Y
- SET DA(2)=VAPRIEN
- +4 SET DA=0
- SET DA=$ORDER(^PSNDF(50.68,6173,11,3,""),-1)
- +5 IF DA=0!(DA="")
- DO ERROR2^PSNPPSNU(PSNTMPN,MROOT,IENS,DA,"Error editing RxNorm multiple - multiple is not defined")
- +6 SET DIE=DIC
- SET IENS=DA_","_DA(1)_","_DA(2)_","
- +7 SET XPATH=$PIECE(^DD(ROOT,.01,0),"^",3)
- SET ROOT3="^"_XPATH_DA(1)_",2,"
- +8 KILL FDA,ERROR
- SET FDA(ROOT,IENS,XFLDS)=NEW
- DO UPDATE^DIE("","FDA",DA,"ERROR")
- +9 SET ROOT=SROOT
- +10 QUIT
- +11 ;
- RXNORMD1(PSNVAPN) ;RxNorm deleted
- +1 NEW CNT,CNT2,DIK,DA,X
- +2 SET CNT=0
- FOR
- SET CNT=$ORDER(^PSNDF(50.68,PSNVAPN,11,CNT))
- if CNT'?1N.N
- QUIT
- Begin DoDot:1
- +3 SET X=""
- SET X=$GET(^PSNDF(50.68,PSNVAPN,11,CNT,0))
- +4 if X=""
- QUIT
- +5 if X'="RxNorm"
- QUIT
- +6 SET DIK="^PSNDF(50.68,"_PSNVAPN_",11,"
- SET DA=CNT
- SET DA(1)=PSNVAPN
- +7 DO ^DIK
- End DoDot:1
- +8 QUIT
- +9 ;
- RXNORMD2(PSNVAPN) ;RxNorm deleted
- +1 NEW CNT,CNT2,DIK,DA,X,OVAL
- +2 SET (CNT2,CNT)=0
- FOR
- SET CNT=$ORDER(^PSNDF(50.68,PSNVAPN,11,CNT))
- if CNT'?1N.N
- QUIT
- FOR
- SET CNT2=$ORDER(^PSNDF(50.68,PSNVAPN,11,CNT,1,CNT2))
- if CNT2'?1N.N
- QUIT
- Begin DoDot:1
- +3 SET X=""
- SET X=$GET(^PSNDF(50.68,PSNVAPN,11,CNT,1,CNT2,0))
- +4 if X=""
- QUIT
- +5 SET OVAL=X
- SET X=NEW
- +6 SET DIK="^PSNDF(50.68,"_PSNVAPN_",11,"_CNT_",1,"
- SET DA=CNT2
- SET DA(1)=CNT
- SET DA(2)=PSNVAPN
- +7 DO ^DIK
- +8 KILL ^PSNDF(50.68,PSNVAPN,11,CNT,CNT2,"B",OVAL)
- End DoDot:1
- +9 QUIT
- +10 ;
- UNMATCH ;DRUGS TO UNMATCH
- +1 NEW DIAFLD,OLDGEN
- +2 SET (DIAFLD,OLDGEN)=""
- SET DIAFLD=$PIECE(DIA,"^",3)
- +3 IF DIAFLD=.05!(DIAFLD=1)!(DIAFLD=2)!(DIAFLD=3)!(DIAFLD=5)!(DIAFLD=6)!(DIAFLD=8)
- Begin DoDot:1
- +4 if $DATA(^TMP("PSN PPSN PARSED",$JOB,"NEW PRODUCTS",+DIA))
- QUIT
- +5 SET ^TMP("PSN PPSN PARSED",$JOB,"PRODUCTS TO UNMATCH",$PIECE(DIA,"^"))=""
- +6 DO SETPROD
- End DoDot:1
- +7 QUIT
- +8 ;
- SETPROD ;
- +1 if PSNPS'="N"
- QUIT
- +2 if $DATA(^NDFK(5000.2,"B",$PIECE(DIA,"^")))
- QUIT
- +3 SET (DINUM,X)=$PIECE(DIA,"^")
- SET DIC=5000.2
- SET DIC(0)="LMXZ"
- DO FILE^DICN
- +4 QUIT
- +5 ;
- AIDEL(PSNVAPD) ; active ingredients deleted
- +1 NEW CNT1,DA,DINUM,X
- +2 SET CNT1=0
- FOR
- SET CNT1=$ORDER(^PSNDF(50.68,PSNVAPD,2,CNT1))
- if CNT1=""
- QUIT
- Begin DoDot:1
- +3 SET DIK="^PSNDF(50.68,"_PSNVAPD_",2,"
- SET DA=CNT1
- SET DA(1)=PSNVAPD
- DO ^DIK
- End DoDot:1
- +4 QUIT