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 Sep 15, 2024@21:48:48 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
