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

IBDECLN.m

Go to the documentation of this file.
  1. IBDECLN ;ALB/AAS - Clean up Data Qualifiers and Package interfaces ; 23-JUN-97
  1. ;;3.0;AUTOMATED INFO COLLECTION SYS;**14,36**;APR 24, 1997
  1. ;
  1. UPDATE(TALK) ; -- update both qualifiers and package interface file
  1. ; -- do the qualifiers first to rename bad ones
  1. ;
  1. ; -- input Talk, 1=send messages through mes^xpdutl (default is 1)
  1. ; 0=no messages
  1. ;
  1. S:$G(TALK)="" TALK=1
  1. S TALK=$TR(TALK,"yesnomaybe","YESNOMAYBE")
  1. S:$G(TALK)="YES" TALK=1
  1. S TALK=+$G(TALK)
  1. D CLNQLF(TALK),CLNPI(TALK)
  1. D CLNSEL^IBDECLN1(TALK)
  1. Q
  1. ;
  1. CLNPI(TALK) ;
  1. ; -- update/delete Allowable Qualifiers in Package Interface file
  1. N I,J,K,L,X,Y,CNT,CNT1,CNT2,CNT3,CNT4,ENTRY,PI,QLF,NODE,FILE
  1. N IEN,PROBLEM,QLFNODE,DATA,QLFNUM,NNODE,ONODE,NLEN,TOT
  1. K ^TMP($J,"IBDE CLN")
  1. S (CNT,CNT1,CNT2,CNT3,CNT4)=0
  1. ;
  1. S (X(1),X(3))=" "
  1. S X(2)=">>> Now checking the PACKAGE INTERFACE file for inappropriate data qualifiers."
  1. D:TALK MES^XPDUTL(.X)
  1. ;
  1. ; -- build array of input package interfaces and qualifiers
  1. ; sent out with version 3.0
  1. S I=0
  1. F I=1:1 S ENTRY=$P($T(OUTPUT+I^IBDECLN2),";;",2) Q:ENTRY="" D
  1. . I $E(ENTRY)="~" Q
  1. . I $E(ENTRY)'="+" D Q
  1. .. S PI=$E($P(ENTRY,":",1),1,30)
  1. .. S DATA=$P(ENTRY,":",2)
  1. .. S ^TMP($J,"IBDE CLN",PI,12)=DATA
  1. . I $E(ENTRY)="+" D Q
  1. .. S QLF=$E($P(ENTRY,":",1),2,99)
  1. .. S QLFNUM=+$O(^IBD(357.98,"B",$E(QLF,1,30),0))
  1. .. Q:QLFNUM=0
  1. .. S DATA=QLFNUM_$P(ENTRY,":",2)
  1. .. S ^TMP($J,"IBDE CLN",PI,"QLF",QLF)=DATA
  1. ;
  1. ; -- now go through the supported list of Package Interface entries
  1. ; and make sure that the main PCE DIM data is correct (node 12)
  1. ;
  1. S PI=""
  1. F S PI=$O(^TMP($J,"IBDE CLN",PI)) Q:PI="" D
  1. . S (J,K)=0
  1. . F S J=$O(^IBE(357.6,"B",PI,J)) Q:'J D
  1. .. S NNODE=$G(^TMP($J,"IBDE CLN",PI,12))
  1. .. Q:NNODE=""
  1. .. S ONODE=$G(^IBE(357.6,J,12))
  1. .. S NLEN=$L(NNODE)
  1. .. I $E(ONODE,1,NLEN)'=NNODE D DEL(TALK,PI,J,K,20,NNODE,ONODE)
  1. ;
  1. ; -- now go through the qualifiers for the package interface
  1. ; and make sure that only supported qualifiers are listed,
  1. ; no duplicates, and that the data is correct.
  1. ;
  1. S PI=""
  1. S (CNT1,CNT3)=0
  1. F S PI=$O(^TMP($J,"IBDE CLN",PI)) Q:PI="" D
  1. . S (J,K)=0
  1. . F S J=$O(^IBE(357.6,"B",PI,J)) Q:'J D
  1. .. N CNT1,ONODE,NNODE,PIQLF
  1. .. S K=0
  1. .. F S K=$O(^IBE(357.6,J,13,K)) Q:K="" D
  1. ... ;
  1. ... S ONODE=$G(^IBE(357.6,J,13,K,0)) Q:ONODE=""
  1. ... S FILE=$P($P(ONODE,"^",1),";",2)
  1. ... Q:FILE'="IBD(357.98,"
  1. ... S IEN=+ONODE
  1. ... S QLF=$P($G(^IBD(357.98,IEN,0),"UNKNOWN"),"^",1)
  1. ... S PIQLF(QLF)=""
  1. ... ;
  1. ... ; -- now if there is a duplicate, delete the duplicate
  1. ... S NNODE=$G(^TMP($J,"IBDE CLN",PI,"QLF",QLF))
  1. ... I NNODE="" D DEL(TALK,PI,J,K,1) Q
  1. ... S CNT1(PI,QLF)=$G(CNT1(PI,QLF))+1
  1. ... I CNT1(PI,QLF)>1 D DEL(TALK,PI,J,K,2) Q
  1. ... ;
  1. ... S NLEN=$L(NNODE)
  1. ... I $E(ONODE,1,NLEN)'=NNODE D DEL(TALK,PI,J,K,21,NNODE,ONODE)
  1. .. ; --check to see if all allowable qualifiers exist if not, add
  1. .. S QLF="" F S QLF=$O(^TMP($J,"IBDE CLN",PI,"QLF",QLF)) Q:QLF']"" D
  1. ... N FILE,DATA,IBDFDA,QLFNODE,NIEN,ERROR
  1. ... Q:$D(PIQLF(QLF))
  1. ... S FILE=357.613,IBDFDA(1)=J
  1. ... S QLFNODE=$G(^TMP($J,"IBDE CLN",PI,"QLF",QLF))
  1. ... S DATA(.01)=$P(QLFNODE,"^")
  1. ... Q:DATA(.01)=""
  1. ... S NIEN=$$ADD^IBDFDBS(FILE,.IBDFDA,.DATA,.ERROR)
  1. ... D:+NIEN>0 DEL(TALK,PI,J,NIEN,22,QLFNODE)
  1. ;
  1. G:'TALK END
  1. ;
  1. ; -- Find out if Problem is in PCE DIM NODE in 357.6
  1. ; if so, then user is warned to contact customer service
  1. ; to be manually corrected
  1. D PROBLEM^IBDECLN1(.PROBLEM)
  1. I PROBLEM>0 D
  1. . S X(1)=" ",X(2)=" >> WARNING: The following interfaces use the PROBLEM node to transmit data"
  1. . D:TALK MES^XPDUTL(.X)
  1. . S I=0 ;skip the zero node, contains PI stuff
  1. . F S I=$O(PROBLEM(I)) Q:I="" D:TALK MES^XPDUTL(" Package Interface "_PROBLEM(I))
  1. . D:TALK MES^XPDUTL(" Contact Customer Support for assistance updating the package interface file.")
  1. ;
  1. ;
  1. SUM ; -- summary of package interface file check
  1. K X
  1. S TOT=2
  1. S X(1)=" "
  1. S X(2)=" >> Summary of the Package Interface Check:"
  1. ;
  1. I CNT<1,CNT2<1,CNT3<1,CNT4<1 D
  1. . S TOT=TOT+1,X(TOT)=" No required changes were found."
  1. ;
  1. I CNT>0 D
  1. . S TOT=TOT+1
  1. . S X(TOT)=" A total of "_CNT_" qualifier"_$S(CNT=1:" was",1:"s were")_" removed from Package Interface Entries."
  1. ;
  1. ;
  1. I CNT2>0 D
  1. . S TOT=TOT+1
  1. . S X(TOT)=" The PCE DIM data fields for "_CNT2_" Package Interface"_$S(CNT2=1:" was",1:"s were")_" updated."
  1. ;
  1. I CNT3>0 D
  1. . S TOT=TOT+1
  1. . S X(TOT)=" The PCE DIM data fields for "_CNT3_" Allowable Qualifier"_$S(CNT3=1:" was",1:"s were")_" updated."
  1. ;
  1. I CNT4>0 D
  1. . S TOT=TOT+1
  1. . S X(TOT)=" A total of "_CNT4_" Allowable Qualifier"_$S(CNT4=1:" was",1:"s were")_" added."
  1. I PROBLEM>0 D
  1. . S TOT=TOT+1,X(TOT)=" Contact Customer Support for assistance updating the package interface file."
  1. ;
  1. D:TALK MES^XPDUTL(.X)
  1. ;
  1. END K ^TMP($J,"IBDE CLN")
  1. Q
  1. ;
  1. DEL(TALK,PI,J,K,REASON,NNODE,ONODE) ; -- delete inappropriate entries
  1. ;
  1. ; reasons for deletion or warnings
  1. ; 1- invalid qualifier
  1. ; 2- duplicate qualifier
  1. ; 9- bad qualifier, not deleted, user warned
  1. ; 20-node ^IBE(357.6,IEN,12) not correct
  1. ; 21-node ^IBE(357.6,IEN,13,allow qual,0) not correct
  1. ;
  1. N I,X,Y,DA,DIC,DIK
  1. I (REASON=1!(REASON=2)) S CNT=CNT+1
  1. S CNT(PI)=+$G(CNT(PI))+1
  1. I CNT(PI)=1 D
  1. . S X(1)=" ",X(2)=" The Package Interface "_PI_" had: "
  1. . D:TALK MES^XPDUTL(.X) N X
  1. D:(TALK&(REASON=1)) MES^XPDUTL(" an invalid qualifier of "_QLF_" deleted.")
  1. D:(TALK&(REASON=2)) MES^XPDUTL(" a duplicate qualifier of "_QLF_" deleted.")
  1. I TALK&(REASON=9) D MES^XPDUTL(" a bad qualifier of "_QLF_" not deleted, PCE DIM NODE='PROBLEM'") Q ;don't delete, save for manual update
  1. ;
  1. I REASON<10 S DA=K,DA(1)=J,DIK="^IBE(357.6,"_DA(1)_",13," D ^DIK Q
  1. ;
  1. I TALK&(REASON=20) D
  1. . N X
  1. . S X(1)=" The PCE Device Interface Data Updated."
  1. . S X(2)=" Old Data: "_ONODE
  1. . S X(3)=" New Data: "_NNODE
  1. . D:TALK MES^XPDUTL(.X)
  1. . S CNT2=CNT2+1
  1. . S ^IBE(357.6,J,12)=NNODE
  1. ;
  1. I TALK&(REASON=21) D
  1. . N X
  1. . S X(1)=" The PCE Device Interface Data for the Data Qualifier "_QLF_" was updated."
  1. . S X(2)=" Old Data: "_ONODE
  1. . S X(3)=" New Data: "_NNODE
  1. . D:TALK MES^XPDUTL(.X)
  1. . S CNT3=CNT3+1
  1. . S ^IBE(357.6,J,13,K,0)=NNODE
  1. ;
  1. I TALK&(REASON=22) D
  1. . S CNT4=CNT4+1
  1. . D MES^XPDUTL(" "_QLF_" was added.")
  1. . S ^IBE(357.6,J,13,K,0)=NNODE
  1. Q
  1. ;
  1. CLNQLF(TALK) ;
  1. ; -- update codes in AICS DATA QUALIFIERS file (357.98)
  1. ; according to version 3.0
  1. N I,J,K,L,X,Y,CNT,CNT1,CNT2,CNT3,ENTRY,NAME,CODE,NEWNAME,IBQUIT,DIC,DIE,DIK,DA,DR
  1. S (CNT,CNT1)=0,CNT2=1
  1. ;
  1. S (X(1),X(3))=" "
  1. S X(2)=">>> Now checking the AICS DATA QUALIFIERS file for inappropriate entries."
  1. D:TALK MES^XPDUTL(.X)
  1. ;
  1. ; -- Go through AICS Data Qualifiers and set up correctly
  1. F I=1:1:28 S ENTRY=$P($T(DATA+I),";;",2) Q:ENTRY="" D
  1. . S CNT=CNT+1
  1. . S NAME=$P(ENTRY,"^",1)
  1. . S CODE=$P(ENTRY,"^",2)
  1. . S J=""
  1. . F S J=$O(^IBD(357.98,"B",NAME,J)) Q:J="" D
  1. .. I $P($G(^IBD(357.98,J,0)),"^",2)=CODE Q
  1. .. ;
  1. .. ; -- don't change Active=1 and Inactive=0 if Problem
  1. .. I $P($G(^IBE(357.6,J,12)),"^",1)="PROBLEM",NAME="ACTIVE"!(NAME="INACTIVE") D Q:IBQUIT
  1. ... S IBQUIT=0
  1. ... I NAME="ACTIVE",($P($G(^IBD(357.98,J,0)),"^",2)=1) D
  1. ....S IBQUIT=1
  1. ....D MES^XPDUTL(" The qualifier ACTIVE with a code of 1 needs to be changed but is used.")
  1. ... I NAME="INACTIVE",($P($G(^IBD(357.98,J,0)),"^",2)=0) D
  1. ....S IBQUIT=1
  1. ....D MES^XPDUTL(" The qualifier of INACTIVE with a code of 0 needs to be changed but is used.")
  1. ..
  1. .. ; -- keep track of what was changed
  1. .. S CNT(NAME)=$G(CNT(NAME))+1
  1. .. S CNT1=CNT1+1,CNT2=CNT2+1
  1. .. S CNT3(CNT2)=" The Entry "_$G(^IBD(357.98,J,0))_" changed to ZZBAD-"_ENTRY
  1. .. ;
  1. .. ; -- see if it's used
  1. .. S K=0 F S K=$O(^IBE(357.6,K)) Q:'K I $D(^IBE(357.6,K,13)) D
  1. ... S L=0 F S L=$O(^IBE(357.6,K,13,L)) Q:'L I $P($G(^IBE(357.6,K,13,L,0)),"^",1)=(J_";IBD(357.98,") D
  1. .... S CNT2=CNT2+1
  1. .... S CNT3(CNT2)=" and was used by Package File entry "_$P($G(^IBE(357.6,K,0)),"^",1)
  1. .. ;
  1. .. ; -- finally, make the change
  1. .. S NEWNAME=$E("ZZBAD-"_$P(^IBD(357.98,J,0),"^",1),1,30)
  1. .. S DIE="^IBD(357.98,",DA=J,DR=".01////^S X=NEWNAME;.02////^S X=CODE"
  1. .. N I,J,K,L,X,Y D ^DIE K DIE,DA,DR
  1. ;
  1. ;
  1. ; -- reindex the file
  1. S DIK="^IBD(357.98,"
  1. D IXALL^DIK
  1. ;
  1. ; summary of the aics data qualifiers check
  1. ;
  1. K X
  1. S X(1)=" ",X(2)=" >> Summary of the AICS Data Qualifiers Check:"
  1. D:TALK MES^XPDUTL(.X)
  1. K X
  1. I $G(CNT1)>0 M X=CNT3 S X(1)=" The number of changes made was "_CNT1
  1. I CNT1=0 S X(1)=" No required changes were found.",X(2)=" "
  1. I CNT1>1 S (X(CNT2+1),X(CNT2+3))=" ",X(CNT2+2)=" >> Done updating the AICS DATA QUALIFIERS file"
  1. D:TALK MES^XPDUTL(.X)
  1. Q
  1. ;
  1. DATA ;;
  1. ;;NONE APPLICABLE^
  1. ;;PRIMARY^P^P
  1. ;;SECONDARY^S^S
  1. ;;ACTIVE^A^A
  1. ;;INACTIVE^I^I
  1. ;;HISTORICAL^H
  1. ;;ADD TO PROBLEM LIST^1^ADD
  1. ;;SERVICE CONNECTED^1^SC
  1. ;;AGENT ORANGE RELATED^1^AO
  1. ;;IONIZING RADIATION RELATED^1^IR
  1. ;;ENVIRONMENTAL CONTAMINANTS RELATED^1^EC
  1. ;;MILITARY SEXUAL TRAUMA^1^MST
  1. ;;ABNORMAL RESULT^A^ABNORM
  1. ;;NORMAL RESULT^N^NORM
  1. ;;POOR UNDERSTANDING^1^POOR
  1. ;;FAIR UNDERSTANDING^2^FAIR
  1. ;;GOOD UNDERSTANDING^3^GOOD
  1. ;;UNDERSTANDING NOT ASSESSED^4^N/A
  1. ;;PATIENT ED REFUSED^5^REFUSED
  1. ;;MINIMAL SEVERITY^M^MINIMAL
  1. ;;MODERATE SEVERITY^MO^MODERATE
  1. ;;HEAVY SEVERITY^H^SEVERE
  1. ;;YES^1^YES
  1. ;;NO^0^NO
  1. ;;CONTRAINDICATED^1^CONTRA.
  1. ;;GIVEN^0^GIV
  1. ;;REFUSED^1^REFUSED
  1. ;;NON-SERVICE CONNECTED^0^NSC
  1. ;;NO CLASSIFICATIONS^1^NO CLASSIF
  1. ;;