- PSNPPSNK ;HP/MJE-PPSN NDFK Updates ; 05 Mar 2014 1:20 PM
- ;;4.0;NATIONAL DRUG FILE;**513**; 30 Oct 98;Build 53
- ;
- INGRED ;50.416
- Q:PSNATYP'="N"
- N FLD3,X,DIC,DINUM,OINGRED S FLD3=$P(DIA,"^",3)
- 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)=""
- I FLD3="99.991,.01" D
- .S (DINUM,X)=+$P(DIA,"^")
- .I NEW'="" I '$D(^NDFK(5000.508,"B",X)) S DIC=5000.508,DIC(0)="LMXZ" D FILE^DICN
- .I NEW="" I '$D(^NDFK(5000.509,"B",X)) S DIC=5000.509,DIC(0)="LMXZ" D FILE^DICN
- Q
- ;
- CPTIER(DIA) ;
- N NAME,X,DIC,DIE,DA,DR
- S NAME=$$GET1^DIQ(50.68,+$P(DIA,"^"),.01,"E")
- S X=NAME,DIC=5000.93,DIC(0)="LMXZ" D ^DIC
- S DIE=DIC,DA=+Y K DIC
- S DR="1///^S X="_1 ;Copay action - 0 = delete or 1 = add/edit
- D ^DIE
- Q
- ;
- NDFK ;Setting NDFK 5000 series files
- ;
- ;ajf / adding code for 5000 series files
- ;man / adding code for 5000.4 (strength changes)
- ;
- N FDA,ERROR,FLD3,OLDV,MGFLG,DIC,OLDGEN,VAGEN,VAGENN,NEWPROD,FDAMED S FLD3=$P(DIA,"^",3)
- I FLD3=40 S DIC="^NDFK(5000.92,",DIC(0)="",(X,DINUM)=$P(DIA,"^") D FILE^DICN
- I FLD3=23 D
- .S (DINUM,X)=$P(DIA,"^"),DIC=5000.23,DIC(0)="LMXZ" D FILE^DICN
- .S DIE=DIC,DA=+Y K DIC
- .S DA=+$P(DIA,"^"),DIE="^NDFK(5000.23,",DR="1///"_NEW D ^DIE
- I FLD3="14,.01" S ^TMP("PSNN",$J,$P(DIA,"^"))="" Q
- I FLD3=.01 S (DINUM,X)=$P(DIA,"^") I '$D(^NDFK(5000.506,"B",X)) S DIC=5000.506,DIC(0)="LMXZ" D FILE^DICN Q
- I FLD3=17 S (DINUM,X)=$P(DIA,"^"),DIC=5000.5,DIC(0)="LMXZ" D FILE^DICN Q
- I FLD3=7 S (DINUM,X)=$P(DIA,"^"),DIC=5000.7,DIC(0)="LMXZ" D FILE^DICN Q
- I FLD3=19 K ERROR S (X,DINUM)=$P(DIA,"^"),DIC="^NDFK(5000.9,",DIC(0)="LMXZ" D FILE^DICN
- ;FDA(5000.9,"+1,"_$P(DIA,"^")_",",.01)=X D UPDATE^DIE("","FDA","","ERROR") D ERROR^PSNPPSNU:$D(ERROR("DIERR")) Q
- ;I FLD3=19 K ERROR S X=$P(DIA,"^"),FDA(5000.9,"+1,"_$P(DIA,"^")_",",.01)=X D UPDATE^DIE("","FDA","","ERROR") D ERROR^PSNPPSNU:$D(ERROR("DIERR")) Q
- I FLD3=15 D Q
- .S NEWPROD=$O(^NDFK(5000.506,"B",$P(DIA,"^"),""))
- .Q:NEWPROD'=""
- .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")
- .K FDA
- .;Does not record class/edits on new VA Products same as NDFRR3 & PSSMIGRR routine
- .I OLDV'="",(OLDV'=NEW) D
- ..S (DINUM,X)=$P(DIA,"^"),DIC=5000.8,DIC(0)="LMXZ" D FILE^DICN
- ..S DIE=DIC,DA=$P(DIA,"^"),DIE=5000.8,DR="1////"_OLDV_";2////"_NEW_";3////"_VAGEN_";4////"_VAGENN D ^DIE
- ..K FDA
- ..S FDA(5000.507,"+1,",.01)=$P(DIA,"^")
- ..S FDA(5000.507,"+1,",1)=$$GET1^DIQ(50.68,$P(DIA,"^"),.01)
- ..S FDA(5000.507,"+1,",2)=OLDV
- ..S FDA(5000.507,"+1,",3)=NEW
- ..K ERROR D UPDATE^DIE("","FDA","","ERROR") D ERROR^PSNPPSNU:$D(ERROR("DIERR"))
- I FLD3=2 S (DINUM,X)=$P(DIA,"^"),DIC=5000.4,DIC(0)="LMXZ" D FILE^DICN
- I FLD3=100 D K FDA Q
- .K FDA,ERROR
- .S MGFLG=0
- .S FDAMED="",FDAMED=$$GET1^DIQ(50.68,$P(DIA,"^"),100)
- .S MGFLG=$S(FDAMED="":"A",NEW="":"D",1:"E")
- .S DIC="^NDFK(5000.91,",DIC(0)="Z",(X,DINUM)=$P(DIA,"^") D FILE^DICN
- .S DIE=DIC,DA=+Y K DIC
- .S DA=IENS,DIE="^NDFK(5000.91,",DA=$P(DIA,"^"),DR="1///"_MGFLG D ^DIE K DIE
- Q
- ;
- POSTRUN ;POST RUN FOR 50.628
- D CTRKDL^PSNPPSMS("POSTRUN of PSNPPSNK processing")
- N PSNPS S PSNPS=$P($G(^PS(59.7,1,10)),"^",12)
- K FDA
- I PSNPS="N" S IENS="" F S IENS=$O(^TMP("PSN PPSN PARSED",$J,"POST_RUN",50.628,50.67,IENS)) Q:IENS="" D
- . S PRNDC=$G(^TMP("PSN PPSN PARSED",$J,"POST_RUN",50.628,50.67,IENS,1))
- . Q:PRNDC=""
- . K PROUT1 D GETS^DIQ(50.67,IENS_",","*","IE","PROUT1")
- . S PRVPIEN=$G(PROUT1(50.67,IENS_",",5,"I"))
- . S PRTR=$G(PROUT1(50.67,IENS_",",4,"E"))
- . S PRPS=$G(PROUT1(50.67,IENS_",",8,"E"))
- . S PRPT=$G(PROUT1(50.67,IENS_",",9,"E"))
- .;
- . K PROUT2 D GETS^DIQ(50.68,PRVPIEN_",","*","IE","PROUT2")
- . S PRVAGN=$G(PROUT2(50.68,PRVPIEN_",",.05,"E"))
- . S PRDFD=$G(PROUT2(50.68,PRVPIEN_",",1,"E"))
- . S PRDS=$G(PROUT2(50.68,PRVPIEN_",",2,"E"))
- . S PRLN=$G(PROUT2(50.68,PRVPIEN_",",5,"E"))
- . S PRLN25=$G(PROUT2(50.68,PRVPIEN_",",6,"E"))
- . S PRVADC=$G(PROUT2(50.68,PRVPIEN_",",15,"E"))
- . S PRPT=$G(PROUT2(50.68,PRVPIEN_",",9,"E"))
- . S PRPS=$G(PROUT2(50.68,PRVPIEN_",",8,"E"))
- . S PRGCN=$G(PROUT2(50.68,PRVPIEN_",",11,"E"))
- . S PRDC=$G(PROUT2(50.68,PRVPIEN_",",15,"E"))
- .;
- . K PROUT3 D GETS^DIQ(50.606,PRDFD_",","*","IE","PROUT3")
- . S PRDF=$G(PROUT3(50.606,PRDFD_",",.01,"E"))
- .;
- . D GCNSEQ(PRNDC)
- . ;
- . K PRNDC,PROUT1,PROUT2,PROUT3,PRVPIEN,PRPS,PRPT,PRGCN,PRVADC,FDA,PRVAGN,PRDF,PRDS,PRDFD,PRPT,PRPS,PRLN
- . K PRLN25,PRTR,PRDC,FDA,ERROR
- ;
- POSTRUN2 ;POST RUN FOR 5000.56
- K IENS
- K FDA,ERROR,DAT56,PROUT4,INACT,STAT,IEN56
- N PSNPS S PSNPS=$P($G(^PS(59.7,1,10)),"^",12)
- Q:PSNPS'="N"
- S IENS="" F S IENS=$O(^TMP("PSN PPSN PARSED",$J,"POST_RUN",5000.56,56,IENS)) Q:IENS="" D
- . S (STAT,INACT)="",STAT=$G(^TMP("PSN PPSN PARSED",$J,"POST_RUN",5000.56,56,IENS,.01))
- . S INACT=$$GET1^DIQ(56,IENS_",",7,"I","ERROR") D ERROR^PSNPPSNU:$D(ERROR("DIERR"))
- . S:INACT'="" STAT="I"
- .S DIC="^NDFK(5000.56,",DIC(0)="Z",(X,DINUM)=IENS D FILE^DICN
- .S DIE=DIC,DA=+Y K DIC
- .S DA=IENS,DIE="^NDFK(5000.56,",DR="1///"_STAT D ^DIE K DIE
- ;
- K FDA,DAT56,PROUT4,INACT,STAT,IEN56,ERROR
- ;
- ;POST RUN FOR 5000.608
- K FDA,IENS,DAT1,ORDP,ORDN,VPIEN
- S IENS="" F S IENS=$O(^TMP("PSN PPSN PARSED",$J,"POST_RUN",5000.608,50.68,IENS)) Q:IENS="" D
- . S ORDP=$G(^TMP("PSN PPSN PARSED",$J,"POST_RUN",5000.608,50.68,IENS,.01))
- . S DAT1=$G(^TMP("PSN PPSN PARSED",$J,"POST_RUN",5000.608,50.68,IENS,31))
- . S:ORDP="" ORDP=$P(DAT1,"^",1)
- . S ORDN=$P(DAT1,"^",2)
- .; S FDA(5000.608,IENS_",",.01)=IENS
- .; S FDA(5000.608,IENS_",",1)=$G(ORDP)
- .; S FDA(5000.608,IENS_",",2)=$G(ORDN)
- .; K ERROR D UPDATE^DIE("","FDA","","ERROR") D ERROR^PSNPPSNU:$D(ERROR("DIERR"))
- .S DIC="^NDFK(5000.608,",DIC(0)="Z",(X,DINUM)=IENS D FILE^DICN
- .S DIE=DIC,DA=+Y K DIC
- .S DA=IENS,DIE="^NDFK(5000.608,",DR="1///"_$G(ORDP)_";2///"_$G(ORDN) D ^DIE K DIE
- .K DAT,ORDP,ORDN,VPIEN
- ;
- ;POST RUN FOR 5000.508 AND 5000.509 - INGREDIENT ADDS AND DELETES
- N IFLDS,IENS,DAT1,ORDP,ORDN,VPIEN,DIC
- S (IENS,VPIEN)=""
- F S IENS=$O(^TMP("PSN ADDINGRED",$J,IENS)) Q:IENS="" D
- .S (DINUM,X)=IENS,DIC=5000.508,DIC(0)="LMXZ" D FILE^DICN
- F S VPIEN=$O(^TMP("PSN DELINGRED",$J,VPIEN)) Q:VPIEN="" D
- .S (DINUM,X)=VPIEN,DIC=5000.509,DIC(0)="LMXZ" D FILE^DICN
- ;
- K ^TMP("PSN PPSN PARSED",$J,"POST_RUN"),^TMP("PSN ADDINGRED",$J),^TMP("PSN OLDINGRED",$J),^TMP("PSN DELINGRED",$J)
- Q
- ;
- NDFKP ;Purging entries in NDFK file
- N PSNATYP S PSNATYP="",PSNATYP=$P(^PS(59.7,1,10),"^",12)
- Q:PSNATYP'="N"
- N FILE,LOC,DA,DIK,DIAU
- ;S (J,DA)=0 F S DA=$O(^NDFK(5000,1,1,DA)) Q:'DA S J=$P(^(DA,0),"^",2)'=$O(^DIA(DA," "),-1)+J
- F FILE=5000.2:0.1:5000.9,5000.23,5000.56,5000.506:0.001:5000.509,5000.608,5000.91,5000.92,5000.93 D
- .S LOC=0 F S LOC=$O(^NDFK(FILE,LOC)) Q:'LOC D
- ..S DA="",DA=LOC,DIK="^NDFK("_FILE_"," D ^DIK K DIK,DIAU
- ;
- K ^NDFK(5000.561)
- K ^NDFK(5000,1,2) ;GET THE MESSAGE
- K ^NDFK(5000,1,3) ;AND THE SECOND MESSAGE
- K ^NDFK(5000,1,4) ;GET THE WORD PROCESSING FIELDS
- Q
- ;
- GCNSEQ(PRNDC) ;
- N X,DIC,DA,DIE,DR,Y
- S X=PRNDC,DIC="^PS(50.628,",DIC(0)="L",DLAYGO=50.628 D FILE^DICN K DIC,DLAYGO S DA=+Y
- S DIE=50.628,DA=+Y
- S DR="1////"_PRGCN_";2////"_PRVAGN_";3////"_PRDFD_";4////"_PRDS_";5////"_PRLN_";6////"_PRLN25_";7////"_PRTR
- S DR=DR_";9////"_PRDF_";11////"_PRPT_";12////"_PRDS_";13////"_PRDC
- D ^DIE K DR
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSNPPSNK 7481 printed Feb 18, 2025@23:51:04 Page 2
- PSNPPSNK ;HP/MJE-PPSN NDFK Updates ; 05 Mar 2014 1:20 PM
- +1 ;;4.0;NATIONAL DRUG FILE;**513**; 30 Oct 98;Build 53
- +2 ;
- INGRED ;50.416
- +1 if PSNATYP'="N"
- QUIT
- +2 NEW FLD3,X,DIC,DINUM,OINGRED
- SET FLD3=$PIECE(DIA,"^",3)
- +3 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)=""
- +4 IF FLD3="99.991,.01"
- Begin DoDot:1
- +5 SET (DINUM,X)=+$PIECE(DIA,"^")
- +6 IF NEW'=""
- IF '$DATA(^NDFK(5000.508,"B",X))
- SET DIC=5000.508
- SET DIC(0)="LMXZ"
- DO FILE^DICN
- +7 IF NEW=""
- IF '$DATA(^NDFK(5000.509,"B",X))
- SET DIC=5000.509
- SET DIC(0)="LMXZ"
- DO FILE^DICN
- End DoDot:1
- +8 QUIT
- +9 ;
- CPTIER(DIA) ;
- +1 NEW NAME,X,DIC,DIE,DA,DR
- +2 SET NAME=$$GET1^DIQ(50.68,+$PIECE(DIA,"^"),.01,"E")
- +3 SET X=NAME
- SET DIC=5000.93
- SET DIC(0)="LMXZ"
- DO ^DIC
- +4 SET DIE=DIC
- SET DA=+Y
- KILL DIC
- +5 ;Copay action - 0 = delete or 1 = add/edit
- SET DR="1///^S X="_1
- +6 DO ^DIE
- +7 QUIT
- +8 ;
- NDFK ;Setting NDFK 5000 series files
- +1 ;
- +2 ;ajf / adding code for 5000 series files
- +3 ;man / adding code for 5000.4 (strength changes)
- +4 ;
- +5 NEW FDA,ERROR,FLD3,OLDV,MGFLG,DIC,OLDGEN,VAGEN,VAGENN,NEWPROD,FDAMED
- SET FLD3=$PIECE(DIA,"^",3)
- +6 IF FLD3=40
- SET DIC="^NDFK(5000.92,"
- SET DIC(0)=""
- SET (X,DINUM)=$PIECE(DIA,"^")
- DO FILE^DICN
- +7 IF FLD3=23
- Begin DoDot:1
- +8 SET (DINUM,X)=$PIECE(DIA,"^")
- SET DIC=5000.23
- SET DIC(0)="LMXZ"
- DO FILE^DICN
- +9 SET DIE=DIC
- SET DA=+Y
- KILL DIC
- +10 SET DA=+$PIECE(DIA,"^")
- SET DIE="^NDFK(5000.23,"
- SET DR="1///"_NEW
- DO ^DIE
- End DoDot:1
- +11 IF FLD3="14,.01"
- SET ^TMP("PSNN",$JOB,$PIECE(DIA,"^"))=""
- QUIT
- +12 IF FLD3=.01
- SET (DINUM,X)=$PIECE(DIA,"^")
- IF '$DATA(^NDFK(5000.506,"B",X))
- SET DIC=5000.506
- SET DIC(0)="LMXZ"
- DO FILE^DICN
- QUIT
- +13 IF FLD3=17
- SET (DINUM,X)=$PIECE(DIA,"^")
- SET DIC=5000.5
- SET DIC(0)="LMXZ"
- DO FILE^DICN
- QUIT
- +14 IF FLD3=7
- SET (DINUM,X)=$PIECE(DIA,"^")
- SET DIC=5000.7
- SET DIC(0)="LMXZ"
- DO FILE^DICN
- QUIT
- +15 IF FLD3=19
- KILL ERROR
- SET (X,DINUM)=$PIECE(DIA,"^")
- SET DIC="^NDFK(5000.9,"
- SET DIC(0)="LMXZ"
- DO FILE^DICN
- +16 ;FDA(5000.9,"+1,"_$P(DIA,"^")_",",.01)=X D UPDATE^DIE("","FDA","","ERROR") D ERROR^PSNPPSNU:$D(ERROR("DIERR")) Q
- +17 ;I FLD3=19 K ERROR S X=$P(DIA,"^"),FDA(5000.9,"+1,"_$P(DIA,"^")_",",.01)=X D UPDATE^DIE("","FDA","","ERROR") D ERROR^PSNPPSNU:$D(ERROR("DIERR")) Q
- +18 IF FLD3=15
- Begin DoDot:1
- +19 SET NEWPROD=$ORDER(^NDFK(5000.506,"B",$PIECE(DIA,"^"),""))
- +20 if NEWPROD'=""
- QUIT
- +21 SET OLDV=$$GET1^DIQ(50.68,$PIECE(DIA,"^"),15,"I")
- SET VAGEN=$$GET1^DIQ(50.68,$PIECE(DIA,"^"),.05,"I")
- +22 SET VAGENN=$$GET1^DIQ(50.68,$PIECE(DIA,"^"),.05,"E")
- +23 KILL FDA
- +24 ;Does not record class/edits on new VA Products same as NDFRR3 & PSSMIGRR routine
- +25 IF OLDV'=""
- IF (OLDV'=NEW)
- Begin DoDot:2
- +26 SET (DINUM,X)=$PIECE(DIA,"^")
- SET DIC=5000.8
- SET DIC(0)="LMXZ"
- DO FILE^DICN
- +27 SET DIE=DIC
- SET DA=$PIECE(DIA,"^")
- SET DIE=5000.8
- SET DR="1////"_OLDV_";2////"_NEW_";3////"_VAGEN_";4////"_VAGENN
- DO ^DIE
- +28 KILL FDA
- +29 SET FDA(5000.507,"+1,",.01)=$PIECE(DIA,"^")
- +30 SET FDA(5000.507,"+1,",1)=$$GET1^DIQ(50.68,$PIECE(DIA,"^"),.01)
- +31 SET FDA(5000.507,"+1,",2)=OLDV
- +32 SET FDA(5000.507,"+1,",3)=NEW
- +33 KILL ERROR
- DO UPDATE^DIE("","FDA","","ERROR")
- if $DATA(ERROR("DIERR"))
- DO ERROR^PSNPPSNU
- End DoDot:2
- End DoDot:1
- QUIT
- +34 IF FLD3=2
- SET (DINUM,X)=$PIECE(DIA,"^")
- SET DIC=5000.4
- SET DIC(0)="LMXZ"
- DO FILE^DICN
- +35 IF FLD3=100
- Begin DoDot:1
- +36 KILL FDA,ERROR
- +37 SET MGFLG=0
- +38 SET FDAMED=""
- SET FDAMED=$$GET1^DIQ(50.68,$PIECE(DIA,"^"),100)
- +39 SET MGFLG=$SELECT(FDAMED="":"A",NEW="":"D",1:"E")
- +40 SET DIC="^NDFK(5000.91,"
- SET DIC(0)="Z"
- SET (X,DINUM)=$PIECE(DIA,"^")
- DO FILE^DICN
- +41 SET DIE=DIC
- SET DA=+Y
- KILL DIC
- +42 SET DA=IENS
- SET DIE="^NDFK(5000.91,"
- SET DA=$PIECE(DIA,"^")
- SET DR="1///"_MGFLG
- DO ^DIE
- KILL DIE
- End DoDot:1
- KILL FDA
- QUIT
- +43 QUIT
- +44 ;
- POSTRUN ;POST RUN FOR 50.628
- +1 DO CTRKDL^PSNPPSMS("POSTRUN of PSNPPSNK processing")
- +2 NEW PSNPS
- SET PSNPS=$PIECE($GET(^PS(59.7,1,10)),"^",12)
- +3 KILL FDA
- +4 IF PSNPS="N"
- SET IENS=""
- FOR
- SET IENS=$ORDER(^TMP("PSN PPSN PARSED",$JOB,"POST_RUN",50.628,50.67,IENS))
- if IENS=""
- QUIT
- Begin DoDot:1
- +5 SET PRNDC=$GET(^TMP("PSN PPSN PARSED",$JOB,"POST_RUN",50.628,50.67,IENS,1))
- +6 if PRNDC=""
- QUIT
- +7 KILL PROUT1
- DO GETS^DIQ(50.67,IENS_",","*","IE","PROUT1")
- +8 SET PRVPIEN=$GET(PROUT1(50.67,IENS_",",5,"I"))
- +9 SET PRTR=$GET(PROUT1(50.67,IENS_",",4,"E"))
- +10 SET PRPS=$GET(PROUT1(50.67,IENS_",",8,"E"))
- +11 SET PRPT=$GET(PROUT1(50.67,IENS_",",9,"E"))
- +12 ;
- +13 KILL PROUT2
- DO GETS^DIQ(50.68,PRVPIEN_",","*","IE","PROUT2")
- +14 SET PRVAGN=$GET(PROUT2(50.68,PRVPIEN_",",.05,"E"))
- +15 SET PRDFD=$GET(PROUT2(50.68,PRVPIEN_",",1,"E"))
- +16 SET PRDS=$GET(PROUT2(50.68,PRVPIEN_",",2,"E"))
- +17 SET PRLN=$GET(PROUT2(50.68,PRVPIEN_",",5,"E"))
- +18 SET PRLN25=$GET(PROUT2(50.68,PRVPIEN_",",6,"E"))
- +19 SET PRVADC=$GET(PROUT2(50.68,PRVPIEN_",",15,"E"))
- +20 SET PRPT=$GET(PROUT2(50.68,PRVPIEN_",",9,"E"))
- +21 SET PRPS=$GET(PROUT2(50.68,PRVPIEN_",",8,"E"))
- +22 SET PRGCN=$GET(PROUT2(50.68,PRVPIEN_",",11,"E"))
- +23 SET PRDC=$GET(PROUT2(50.68,PRVPIEN_",",15,"E"))
- +24 ;
- +25 KILL PROUT3
- DO GETS^DIQ(50.606,PRDFD_",","*","IE","PROUT3")
- +26 SET PRDF=$GET(PROUT3(50.606,PRDFD_",",.01,"E"))
- +27 ;
- +28 DO GCNSEQ(PRNDC)
- +29 ;
- +30 KILL PRNDC,PROUT1,PROUT2,PROUT3,PRVPIEN,PRPS,PRPT,PRGCN,PRVADC,FDA,PRVAGN,PRDF,PRDS,PRDFD,PRPT,PRPS,PRLN
- +31 KILL PRLN25,PRTR,PRDC,FDA,ERROR
- End DoDot:1
- +32 ;
- POSTRUN2 ;POST RUN FOR 5000.56
- +1 KILL IENS
- +2 KILL FDA,ERROR,DAT56,PROUT4,INACT,STAT,IEN56
- +3 NEW PSNPS
- SET PSNPS=$PIECE($GET(^PS(59.7,1,10)),"^",12)
- +4 if PSNPS'="N"
- QUIT
- +5 SET IENS=""
- FOR
- SET IENS=$ORDER(^TMP("PSN PPSN PARSED",$JOB,"POST_RUN",5000.56,56,IENS))
- if IENS=""
- QUIT
- Begin DoDot:1
- +6 SET (STAT,INACT)=""
- SET STAT=$GET(^TMP("PSN PPSN PARSED",$JOB,"POST_RUN",5000.56,56,IENS,.01))
- +7 SET INACT=$$GET1^DIQ(56,IENS_",",7,"I","ERROR")
- if $DATA(ERROR("DIERR"))
- DO ERROR^PSNPPSNU
- +8 if INACT'=""
- SET STAT="I"
- +9 SET DIC="^NDFK(5000.56,"
- SET DIC(0)="Z"
- SET (X,DINUM)=IENS
- DO FILE^DICN
- +10 SET DIE=DIC
- SET DA=+Y
- KILL DIC
- +11 SET DA=IENS
- SET DIE="^NDFK(5000.56,"
- SET DR="1///"_STAT
- DO ^DIE
- KILL DIE
- End DoDot:1
- +12 ;
- +13 KILL FDA,DAT56,PROUT4,INACT,STAT,IEN56,ERROR
- +14 ;
- +15 ;POST RUN FOR 5000.608
- +16 KILL FDA,IENS,DAT1,ORDP,ORDN,VPIEN
- +17 SET IENS=""
- FOR
- SET IENS=$ORDER(^TMP("PSN PPSN PARSED",$JOB,"POST_RUN",5000.608,50.68,IENS))
- if IENS=""
- QUIT
- Begin DoDot:1
- +18 SET ORDP=$GET(^TMP("PSN PPSN PARSED",$JOB,"POST_RUN",5000.608,50.68,IENS,.01))
- +19 SET DAT1=$GET(^TMP("PSN PPSN PARSED",$JOB,"POST_RUN",5000.608,50.68,IENS,31))
- +20 if ORDP=""
- SET ORDP=$PIECE(DAT1,"^",1)
- +21 SET ORDN=$PIECE(DAT1,"^",2)
- +22 ; S FDA(5000.608,IENS_",",.01)=IENS
- +23 ; S FDA(5000.608,IENS_",",1)=$G(ORDP)
- +24 ; S FDA(5000.608,IENS_",",2)=$G(ORDN)
- +25 ; K ERROR D UPDATE^DIE("","FDA","","ERROR") D ERROR^PSNPPSNU:$D(ERROR("DIERR"))
- +26 SET DIC="^NDFK(5000.608,"
- SET DIC(0)="Z"
- SET (X,DINUM)=IENS
- DO FILE^DICN
- +27 SET DIE=DIC
- SET DA=+Y
- KILL DIC
- +28 SET DA=IENS
- SET DIE="^NDFK(5000.608,"
- SET DR="1///"_$GET(ORDP)_";2///"_$GET(ORDN)
- DO ^DIE
- KILL DIE
- +29 KILL DAT,ORDP,ORDN,VPIEN
- End DoDot:1
- +30 ;
- +31 ;POST RUN FOR 5000.508 AND 5000.509 - INGREDIENT ADDS AND DELETES
- +32 NEW IFLDS,IENS,DAT1,ORDP,ORDN,VPIEN,DIC
- +33 SET (IENS,VPIEN)=""
- +34 FOR
- SET IENS=$ORDER(^TMP("PSN ADDINGRED",$JOB,IENS))
- if IENS=""
- QUIT
- Begin DoDot:1
- +35 SET (DINUM,X)=IENS
- SET DIC=5000.508
- SET DIC(0)="LMXZ"
- DO FILE^DICN
- End DoDot:1
- +36 FOR
- SET VPIEN=$ORDER(^TMP("PSN DELINGRED",$JOB,VPIEN))
- if VPIEN=""
- QUIT
- Begin DoDot:1
- +37 SET (DINUM,X)=VPIEN
- SET DIC=5000.509
- SET DIC(0)="LMXZ"
- DO FILE^DICN
- End DoDot:1
- +38 ;
- +39 KILL ^TMP("PSN PPSN PARSED",$JOB,"POST_RUN"),^TMP("PSN ADDINGRED",$JOB),^TMP("PSN OLDINGRED",$JOB),^TMP("PSN DELINGRED",$JOB)
- +40 QUIT
- +41 ;
- NDFKP ;Purging entries in NDFK file
- +1 NEW PSNATYP
- SET PSNATYP=""
- SET PSNATYP=$PIECE(^PS(59.7,1,10),"^",12)
- +2 if PSNATYP'="N"
- QUIT
- +3 NEW FILE,LOC,DA,DIK,DIAU
- +4 ;S (J,DA)=0 F S DA=$O(^NDFK(5000,1,1,DA)) Q:'DA S J=$P(^(DA,0),"^",2)'=$O(^DIA(DA," "),-1)+J
- +5 FOR FILE=5000.2:0.1:5000.9,5000.23,5000.56,5000.506:0.001:5000.509,5000.608,5000.91,5000.92,5000.93
- Begin DoDot:1
- +6 SET LOC=0
- FOR
- SET LOC=$ORDER(^NDFK(FILE,LOC))
- if 'LOC
- QUIT
- Begin DoDot:2
- +7 SET DA=""
- SET DA=LOC
- SET DIK="^NDFK("_FILE_","
- DO ^DIK
- KILL DIK,DIAU
- End DoDot:2
- End DoDot:1
- +8 ;
- +9 KILL ^NDFK(5000.561)
- +10 ;GET THE MESSAGE
- KILL ^NDFK(5000,1,2)
- +11 ;AND THE SECOND MESSAGE
- KILL ^NDFK(5000,1,3)
- +12 ;GET THE WORD PROCESSING FIELDS
- KILL ^NDFK(5000,1,4)
- +13 QUIT
- +14 ;
- GCNSEQ(PRNDC) ;
- +1 NEW X,DIC,DA,DIE,DR,Y
- +2 SET X=PRNDC
- SET DIC="^PS(50.628,"
- SET DIC(0)="L"
- SET DLAYGO=50.628
- DO FILE^DICN
- KILL DIC,DLAYGO
- SET DA=+Y
- +3 SET DIE=50.628
- SET DA=+Y
- +4 SET DR="1////"_PRGCN_";2////"_PRVAGN_";3////"_PRDFD_";4////"_PRDS_";5////"_PRLN_";6////"_PRLN25_";7////"_PRTR
- +5 SET DR=DR_";9////"_PRDF_";11////"_PRPT_";12////"_PRDS_";13////"_PRDC
- +6 DO ^DIE
- KILL DR
- +7 QUIT
- +8 ;