- IBDECLN ;ALB/AAS - Clean up Data Qualifiers and Package interfaces ; 23-JUN-97
- ;;3.0;AUTOMATED INFO COLLECTION SYS;**14,36**;APR 24, 1997
- ;
- UPDATE(TALK) ; -- update both qualifiers and package interface file
- ; -- do the qualifiers first to rename bad ones
- ;
- ; -- input Talk, 1=send messages through mes^xpdutl (default is 1)
- ; 0=no messages
- ;
- S:$G(TALK)="" TALK=1
- S TALK=$TR(TALK,"yesnomaybe","YESNOMAYBE")
- S:$G(TALK)="YES" TALK=1
- S TALK=+$G(TALK)
- D CLNQLF(TALK),CLNPI(TALK)
- D CLNSEL^IBDECLN1(TALK)
- Q
- ;
- CLNPI(TALK) ;
- ; -- update/delete Allowable Qualifiers in Package Interface file
- N I,J,K,L,X,Y,CNT,CNT1,CNT2,CNT3,CNT4,ENTRY,PI,QLF,NODE,FILE
- N IEN,PROBLEM,QLFNODE,DATA,QLFNUM,NNODE,ONODE,NLEN,TOT
- K ^TMP($J,"IBDE CLN")
- S (CNT,CNT1,CNT2,CNT3,CNT4)=0
- ;
- S (X(1),X(3))=" "
- S X(2)=">>> Now checking the PACKAGE INTERFACE file for inappropriate data qualifiers."
- D:TALK MES^XPDUTL(.X)
- ;
- ; -- build array of input package interfaces and qualifiers
- ; sent out with version 3.0
- S I=0
- F I=1:1 S ENTRY=$P($T(OUTPUT+I^IBDECLN2),";;",2) Q:ENTRY="" D
- . I $E(ENTRY)="~" Q
- . I $E(ENTRY)'="+" D Q
- .. S PI=$E($P(ENTRY,":",1),1,30)
- .. S DATA=$P(ENTRY,":",2)
- .. S ^TMP($J,"IBDE CLN",PI,12)=DATA
- . I $E(ENTRY)="+" D Q
- .. S QLF=$E($P(ENTRY,":",1),2,99)
- .. S QLFNUM=+$O(^IBD(357.98,"B",$E(QLF,1,30),0))
- .. Q:QLFNUM=0
- .. S DATA=QLFNUM_$P(ENTRY,":",2)
- .. S ^TMP($J,"IBDE CLN",PI,"QLF",QLF)=DATA
- ;
- ; -- now go through the supported list of Package Interface entries
- ; and make sure that the main PCE DIM data is correct (node 12)
- ;
- S PI=""
- F S PI=$O(^TMP($J,"IBDE CLN",PI)) Q:PI="" D
- . S (J,K)=0
- . F S J=$O(^IBE(357.6,"B",PI,J)) Q:'J D
- .. S NNODE=$G(^TMP($J,"IBDE CLN",PI,12))
- .. Q:NNODE=""
- .. S ONODE=$G(^IBE(357.6,J,12))
- .. S NLEN=$L(NNODE)
- .. I $E(ONODE,1,NLEN)'=NNODE D DEL(TALK,PI,J,K,20,NNODE,ONODE)
- ;
- ; -- now go through the qualifiers for the package interface
- ; and make sure that only supported qualifiers are listed,
- ; no duplicates, and that the data is correct.
- ;
- S PI=""
- S (CNT1,CNT3)=0
- F S PI=$O(^TMP($J,"IBDE CLN",PI)) Q:PI="" D
- . S (J,K)=0
- . F S J=$O(^IBE(357.6,"B",PI,J)) Q:'J D
- .. N CNT1,ONODE,NNODE,PIQLF
- .. S K=0
- .. F S K=$O(^IBE(357.6,J,13,K)) Q:K="" D
- ... ;
- ... S ONODE=$G(^IBE(357.6,J,13,K,0)) Q:ONODE=""
- ... S FILE=$P($P(ONODE,"^",1),";",2)
- ... Q:FILE'="IBD(357.98,"
- ... S IEN=+ONODE
- ... S QLF=$P($G(^IBD(357.98,IEN,0),"UNKNOWN"),"^",1)
- ... S PIQLF(QLF)=""
- ... ;
- ... ; -- now if there is a duplicate, delete the duplicate
- ... S NNODE=$G(^TMP($J,"IBDE CLN",PI,"QLF",QLF))
- ... I NNODE="" D DEL(TALK,PI,J,K,1) Q
- ... S CNT1(PI,QLF)=$G(CNT1(PI,QLF))+1
- ... I CNT1(PI,QLF)>1 D DEL(TALK,PI,J,K,2) Q
- ... ;
- ... S NLEN=$L(NNODE)
- ... I $E(ONODE,1,NLEN)'=NNODE D DEL(TALK,PI,J,K,21,NNODE,ONODE)
- .. ; --check to see if all allowable qualifiers exist if not, add
- .. S QLF="" F S QLF=$O(^TMP($J,"IBDE CLN",PI,"QLF",QLF)) Q:QLF']"" D
- ... N FILE,DATA,IBDFDA,QLFNODE,NIEN,ERROR
- ... Q:$D(PIQLF(QLF))
- ... S FILE=357.613,IBDFDA(1)=J
- ... S QLFNODE=$G(^TMP($J,"IBDE CLN",PI,"QLF",QLF))
- ... S DATA(.01)=$P(QLFNODE,"^")
- ... Q:DATA(.01)=""
- ... S NIEN=$$ADD^IBDFDBS(FILE,.IBDFDA,.DATA,.ERROR)
- ... D:+NIEN>0 DEL(TALK,PI,J,NIEN,22,QLFNODE)
- ;
- G:'TALK END
- ;
- ; -- Find out if Problem is in PCE DIM NODE in 357.6
- ; if so, then user is warned to contact customer service
- ; to be manually corrected
- D PROBLEM^IBDECLN1(.PROBLEM)
- I PROBLEM>0 D
- . S X(1)=" ",X(2)=" >> WARNING: The following interfaces use the PROBLEM node to transmit data"
- . D:TALK MES^XPDUTL(.X)
- . S I=0 ;skip the zero node, contains PI stuff
- . F S I=$O(PROBLEM(I)) Q:I="" D:TALK MES^XPDUTL(" Package Interface "_PROBLEM(I))
- . D:TALK MES^XPDUTL(" Contact Customer Support for assistance updating the package interface file.")
- ;
- ;
- SUM ; -- summary of package interface file check
- K X
- S TOT=2
- S X(1)=" "
- S X(2)=" >> Summary of the Package Interface Check:"
- ;
- I CNT<1,CNT2<1,CNT3<1,CNT4<1 D
- . S TOT=TOT+1,X(TOT)=" No required changes were found."
- ;
- I CNT>0 D
- . S TOT=TOT+1
- . S X(TOT)=" A total of "_CNT_" qualifier"_$S(CNT=1:" was",1:"s were")_" removed from Package Interface Entries."
- ;
- ;
- I CNT2>0 D
- . S TOT=TOT+1
- . S X(TOT)=" The PCE DIM data fields for "_CNT2_" Package Interface"_$S(CNT2=1:" was",1:"s were")_" updated."
- ;
- I CNT3>0 D
- . S TOT=TOT+1
- . S X(TOT)=" The PCE DIM data fields for "_CNT3_" Allowable Qualifier"_$S(CNT3=1:" was",1:"s were")_" updated."
- ;
- I CNT4>0 D
- . S TOT=TOT+1
- . S X(TOT)=" A total of "_CNT4_" Allowable Qualifier"_$S(CNT4=1:" was",1:"s were")_" added."
- I PROBLEM>0 D
- . S TOT=TOT+1,X(TOT)=" Contact Customer Support for assistance updating the package interface file."
- ;
- D:TALK MES^XPDUTL(.X)
- ;
- END K ^TMP($J,"IBDE CLN")
- Q
- ;
- DEL(TALK,PI,J,K,REASON,NNODE,ONODE) ; -- delete inappropriate entries
- ;
- ; reasons for deletion or warnings
- ; 1- invalid qualifier
- ; 2- duplicate qualifier
- ; 9- bad qualifier, not deleted, user warned
- ; 20-node ^IBE(357.6,IEN,12) not correct
- ; 21-node ^IBE(357.6,IEN,13,allow qual,0) not correct
- ;
- N I,X,Y,DA,DIC,DIK
- I (REASON=1!(REASON=2)) S CNT=CNT+1
- S CNT(PI)=+$G(CNT(PI))+1
- I CNT(PI)=1 D
- . S X(1)=" ",X(2)=" The Package Interface "_PI_" had: "
- . D:TALK MES^XPDUTL(.X) N X
- D:(TALK&(REASON=1)) MES^XPDUTL(" an invalid qualifier of "_QLF_" deleted.")
- D:(TALK&(REASON=2)) MES^XPDUTL(" a duplicate qualifier of "_QLF_" deleted.")
- 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
- ;
- I REASON<10 S DA=K,DA(1)=J,DIK="^IBE(357.6,"_DA(1)_",13," D ^DIK Q
- ;
- I TALK&(REASON=20) D
- . N X
- . S X(1)=" The PCE Device Interface Data Updated."
- . S X(2)=" Old Data: "_ONODE
- . S X(3)=" New Data: "_NNODE
- . D:TALK MES^XPDUTL(.X)
- . S CNT2=CNT2+1
- . S ^IBE(357.6,J,12)=NNODE
- ;
- I TALK&(REASON=21) D
- . N X
- . S X(1)=" The PCE Device Interface Data for the Data Qualifier "_QLF_" was updated."
- . S X(2)=" Old Data: "_ONODE
- . S X(3)=" New Data: "_NNODE
- . D:TALK MES^XPDUTL(.X)
- . S CNT3=CNT3+1
- . S ^IBE(357.6,J,13,K,0)=NNODE
- ;
- I TALK&(REASON=22) D
- . S CNT4=CNT4+1
- . D MES^XPDUTL(" "_QLF_" was added.")
- . S ^IBE(357.6,J,13,K,0)=NNODE
- Q
- ;
- CLNQLF(TALK) ;
- ; -- update codes in AICS DATA QUALIFIERS file (357.98)
- ; according to version 3.0
- N I,J,K,L,X,Y,CNT,CNT1,CNT2,CNT3,ENTRY,NAME,CODE,NEWNAME,IBQUIT,DIC,DIE,DIK,DA,DR
- S (CNT,CNT1)=0,CNT2=1
- ;
- S (X(1),X(3))=" "
- S X(2)=">>> Now checking the AICS DATA QUALIFIERS file for inappropriate entries."
- D:TALK MES^XPDUTL(.X)
- ;
- ; -- Go through AICS Data Qualifiers and set up correctly
- F I=1:1:28 S ENTRY=$P($T(DATA+I),";;",2) Q:ENTRY="" D
- . S CNT=CNT+1
- . S NAME=$P(ENTRY,"^",1)
- . S CODE=$P(ENTRY,"^",2)
- . S J=""
- . F S J=$O(^IBD(357.98,"B",NAME,J)) Q:J="" D
- .. I $P($G(^IBD(357.98,J,0)),"^",2)=CODE Q
- .. ;
- .. ; -- don't change Active=1 and Inactive=0 if Problem
- .. I $P($G(^IBE(357.6,J,12)),"^",1)="PROBLEM",NAME="ACTIVE"!(NAME="INACTIVE") D Q:IBQUIT
- ... S IBQUIT=0
- ... I NAME="ACTIVE",($P($G(^IBD(357.98,J,0)),"^",2)=1) D
- ....S IBQUIT=1
- ....D MES^XPDUTL(" The qualifier ACTIVE with a code of 1 needs to be changed but is used.")
- ... I NAME="INACTIVE",($P($G(^IBD(357.98,J,0)),"^",2)=0) D
- ....S IBQUIT=1
- ....D MES^XPDUTL(" The qualifier of INACTIVE with a code of 0 needs to be changed but is used.")
- ..
- .. ; -- keep track of what was changed
- .. S CNT(NAME)=$G(CNT(NAME))+1
- .. S CNT1=CNT1+1,CNT2=CNT2+1
- .. S CNT3(CNT2)=" The Entry "_$G(^IBD(357.98,J,0))_" changed to ZZBAD-"_ENTRY
- .. ;
- .. ; -- see if it's used
- .. S K=0 F S K=$O(^IBE(357.6,K)) Q:'K I $D(^IBE(357.6,K,13)) D
- ... 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
- .... S CNT2=CNT2+1
- .... S CNT3(CNT2)=" and was used by Package File entry "_$P($G(^IBE(357.6,K,0)),"^",1)
- .. ;
- .. ; -- finally, make the change
- .. S NEWNAME=$E("ZZBAD-"_$P(^IBD(357.98,J,0),"^",1),1,30)
- .. S DIE="^IBD(357.98,",DA=J,DR=".01////^S X=NEWNAME;.02////^S X=CODE"
- .. N I,J,K,L,X,Y D ^DIE K DIE,DA,DR
- ;
- ;
- ; -- reindex the file
- S DIK="^IBD(357.98,"
- D IXALL^DIK
- ;
- ; summary of the aics data qualifiers check
- ;
- K X
- S X(1)=" ",X(2)=" >> Summary of the AICS Data Qualifiers Check:"
- D:TALK MES^XPDUTL(.X)
- K X
- I $G(CNT1)>0 M X=CNT3 S X(1)=" The number of changes made was "_CNT1
- I CNT1=0 S X(1)=" No required changes were found.",X(2)=" "
- I CNT1>1 S (X(CNT2+1),X(CNT2+3))=" ",X(CNT2+2)=" >> Done updating the AICS DATA QUALIFIERS file"
- D:TALK MES^XPDUTL(.X)
- Q
- ;
- DATA ;;
- ;;NONE APPLICABLE^
- ;;PRIMARY^P^P
- ;;SECONDARY^S^S
- ;;ACTIVE^A^A
- ;;INACTIVE^I^I
- ;;HISTORICAL^H
- ;;ADD TO PROBLEM LIST^1^ADD
- ;;SERVICE CONNECTED^1^SC
- ;;AGENT ORANGE RELATED^1^AO
- ;;IONIZING RADIATION RELATED^1^IR
- ;;ENVIRONMENTAL CONTAMINANTS RELATED^1^EC
- ;;MILITARY SEXUAL TRAUMA^1^MST
- ;;ABNORMAL RESULT^A^ABNORM
- ;;NORMAL RESULT^N^NORM
- ;;POOR UNDERSTANDING^1^POOR
- ;;FAIR UNDERSTANDING^2^FAIR
- ;;GOOD UNDERSTANDING^3^GOOD
- ;;UNDERSTANDING NOT ASSESSED^4^N/A
- ;;PATIENT ED REFUSED^5^REFUSED
- ;;MINIMAL SEVERITY^M^MINIMAL
- ;;MODERATE SEVERITY^MO^MODERATE
- ;;HEAVY SEVERITY^H^SEVERE
- ;;YES^1^YES
- ;;NO^0^NO
- ;;CONTRAINDICATED^1^CONTRA.
- ;;GIVEN^0^GIV
- ;;REFUSED^1^REFUSED
- ;;NON-SERVICE CONNECTED^0^NSC
- ;;NO CLASSIFICATIONS^1^NO CLASSIF
- ;;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDECLN 9693 printed Jan 18, 2025@02:40:06 Page 2
- 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
- +2 ;
- UPDATE(TALK) ; -- update both qualifiers and package interface file
- +1 ; -- do the qualifiers first to rename bad ones
- +2 ;
- +3 ; -- input Talk, 1=send messages through mes^xpdutl (default is 1)
- +4 ; 0=no messages
- +5 ;
- +6 if $GET(TALK)=""
- SET TALK=1
- +7 SET TALK=$TRANSLATE(TALK,"yesnomaybe","YESNOMAYBE")
- +8 if $GET(TALK)="YES"
- SET TALK=1
- +9 SET TALK=+$GET(TALK)
- +10 DO CLNQLF(TALK)
- DO CLNPI(TALK)
- +11 DO CLNSEL^IBDECLN1(TALK)
- +12 QUIT
- +13 ;
- CLNPI(TALK) ;
- +1 ; -- update/delete Allowable Qualifiers in Package Interface file
- +2 NEW I,J,K,L,X,Y,CNT,CNT1,CNT2,CNT3,CNT4,ENTRY,PI,QLF,NODE,FILE
- +3 NEW IEN,PROBLEM,QLFNODE,DATA,QLFNUM,NNODE,ONODE,NLEN,TOT
- +4 KILL ^TMP($JOB,"IBDE CLN")
- +5 SET (CNT,CNT1,CNT2,CNT3,CNT4)=0
- +6 ;
- +7 SET (X(1),X(3))=" "
- +8 SET X(2)=">>> Now checking the PACKAGE INTERFACE file for inappropriate data qualifiers."
- +9 if TALK
- DO MES^XPDUTL(.X)
- +10 ;
- +11 ; -- build array of input package interfaces and qualifiers
- +12 ; sent out with version 3.0
- +13 SET I=0
- +14 FOR I=1:1
- SET ENTRY=$PIECE($TEXT(OUTPUT+I^IBDECLN2),";;",2)
- if ENTRY=""
- QUIT
- Begin DoDot:1
- +15 IF $EXTRACT(ENTRY)="~"
- QUIT
- +16 IF $EXTRACT(ENTRY)'="+"
- Begin DoDot:2
- +17 SET PI=$EXTRACT($PIECE(ENTRY,":",1),1,30)
- +18 SET DATA=$PIECE(ENTRY,":",2)
- +19 SET ^TMP($JOB,"IBDE CLN",PI,12)=DATA
- End DoDot:2
- QUIT
- +20 IF $EXTRACT(ENTRY)="+"
- Begin DoDot:2
- +21 SET QLF=$EXTRACT($PIECE(ENTRY,":",1),2,99)
- +22 SET QLFNUM=+$ORDER(^IBD(357.98,"B",$EXTRACT(QLF,1,30),0))
- +23 if QLFNUM=0
- QUIT
- +24 SET DATA=QLFNUM_$PIECE(ENTRY,":",2)
- +25 SET ^TMP($JOB,"IBDE CLN",PI,"QLF",QLF)=DATA
- End DoDot:2
- QUIT
- End DoDot:1
- +26 ;
- +27 ; -- now go through the supported list of Package Interface entries
- +28 ; and make sure that the main PCE DIM data is correct (node 12)
- +29 ;
- +30 SET PI=""
- +31 FOR
- SET PI=$ORDER(^TMP($JOB,"IBDE CLN",PI))
- if PI=""
- QUIT
- Begin DoDot:1
- +32 SET (J,K)=0
- +33 FOR
- SET J=$ORDER(^IBE(357.6,"B",PI,J))
- if 'J
- QUIT
- Begin DoDot:2
- +34 SET NNODE=$GET(^TMP($JOB,"IBDE CLN",PI,12))
- +35 if NNODE=""
- QUIT
- +36 SET ONODE=$GET(^IBE(357.6,J,12))
- +37 SET NLEN=$LENGTH(NNODE)
- +38 IF $EXTRACT(ONODE,1,NLEN)'=NNODE
- DO DEL(TALK,PI,J,K,20,NNODE,ONODE)
- End DoDot:2
- End DoDot:1
- +39 ;
- +40 ; -- now go through the qualifiers for the package interface
- +41 ; and make sure that only supported qualifiers are listed,
- +42 ; no duplicates, and that the data is correct.
- +43 ;
- +44 SET PI=""
- +45 SET (CNT1,CNT3)=0
- +46 FOR
- SET PI=$ORDER(^TMP($JOB,"IBDE CLN",PI))
- if PI=""
- QUIT
- Begin DoDot:1
- +47 SET (J,K)=0
- +48 FOR
- SET J=$ORDER(^IBE(357.6,"B",PI,J))
- if 'J
- QUIT
- Begin DoDot:2
- +49 NEW CNT1,ONODE,NNODE,PIQLF
- +50 SET K=0
- +51 FOR
- SET K=$ORDER(^IBE(357.6,J,13,K))
- if K=""
- QUIT
- Begin DoDot:3
- +52 ;
- +53 SET ONODE=$GET(^IBE(357.6,J,13,K,0))
- if ONODE=""
- QUIT
- +54 SET FILE=$PIECE($PIECE(ONODE,"^",1),";",2)
- +55 if FILE'="IBD(357.98,"
- QUIT
- +56 SET IEN=+ONODE
- +57 SET QLF=$PIECE($GET(^IBD(357.98,IEN,0),"UNKNOWN"),"^",1)
- +58 SET PIQLF(QLF)=""
- +59 ;
- +60 ; -- now if there is a duplicate, delete the duplicate
- +61 SET NNODE=$GET(^TMP($JOB,"IBDE CLN",PI,"QLF",QLF))
- +62 IF NNODE=""
- DO DEL(TALK,PI,J,K,1)
- QUIT
- +63 SET CNT1(PI,QLF)=$GET(CNT1(PI,QLF))+1
- +64 IF CNT1(PI,QLF)>1
- DO DEL(TALK,PI,J,K,2)
- QUIT
- +65 ;
- +66 SET NLEN=$LENGTH(NNODE)
- +67 IF $EXTRACT(ONODE,1,NLEN)'=NNODE
- DO DEL(TALK,PI,J,K,21,NNODE,ONODE)
- End DoDot:3
- +68 ; --check to see if all allowable qualifiers exist if not, add
- +69 SET QLF=""
- FOR
- SET QLF=$ORDER(^TMP($JOB,"IBDE CLN",PI,"QLF",QLF))
- if QLF']""
- QUIT
- Begin DoDot:3
- +70 NEW FILE,DATA,IBDFDA,QLFNODE,NIEN,ERROR
- +71 if $DATA(PIQLF(QLF))
- QUIT
- +72 SET FILE=357.613
- SET IBDFDA(1)=J
- +73 SET QLFNODE=$GET(^TMP($JOB,"IBDE CLN",PI,"QLF",QLF))
- +74 SET DATA(.01)=$PIECE(QLFNODE,"^")
- +75 if DATA(.01)=""
- QUIT
- +76 SET NIEN=$$ADD^IBDFDBS(FILE,.IBDFDA,.DATA,.ERROR)
- +77 if +NIEN>0
- DO DEL(TALK,PI,J,NIEN,22,QLFNODE)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +78 ;
- +79 if 'TALK
- GOTO END
- +80 ;
- +81 ; -- Find out if Problem is in PCE DIM NODE in 357.6
- +82 ; if so, then user is warned to contact customer service
- +83 ; to be manually corrected
- +84 DO PROBLEM^IBDECLN1(.PROBLEM)
- +85 IF PROBLEM>0
- Begin DoDot:1
- +86 SET X(1)=" "
- SET X(2)=" >> WARNING: The following interfaces use the PROBLEM node to transmit data"
- +87 if TALK
- DO MES^XPDUTL(.X)
- +88 ;skip the zero node, contains PI stuff
- SET I=0
- +89 FOR
- SET I=$ORDER(PROBLEM(I))
- if I=""
- QUIT
- if TALK
- DO MES^XPDUTL(" Package Interface "_PROBLEM(I))
- +90 if TALK
- DO MES^XPDUTL(" Contact Customer Support for assistance updating the package interface file.")
- End DoDot:1
- +91 ;
- +92 ;
- SUM ; -- summary of package interface file check
- +1 KILL X
- +2 SET TOT=2
- +3 SET X(1)=" "
- +4 SET X(2)=" >> Summary of the Package Interface Check:"
- +5 ;
- +6 IF CNT<1
- IF CNT2<1
- IF CNT3<1
- IF CNT4<1
- Begin DoDot:1
- +7 SET TOT=TOT+1
- SET X(TOT)=" No required changes were found."
- End DoDot:1
- +8 ;
- +9 IF CNT>0
- Begin DoDot:1
- +10 SET TOT=TOT+1
- +11 SET X(TOT)=" A total of "_CNT_" qualifier"_$SELECT(CNT=1:" was",1:"s were")_" removed from Package Interface Entries."
- End DoDot:1
- +12 ;
- +13 ;
- +14 IF CNT2>0
- Begin DoDot:1
- +15 SET TOT=TOT+1
- +16 SET X(TOT)=" The PCE DIM data fields for "_CNT2_" Package Interface"_$SELECT(CNT2=1:" was",1:"s were")_" updated."
- End DoDot:1
- +17 ;
- +18 IF CNT3>0
- Begin DoDot:1
- +19 SET TOT=TOT+1
- +20 SET X(TOT)=" The PCE DIM data fields for "_CNT3_" Allowable Qualifier"_$SELECT(CNT3=1:" was",1:"s were")_" updated."
- End DoDot:1
- +21 ;
- +22 IF CNT4>0
- Begin DoDot:1
- +23 SET TOT=TOT+1
- +24 SET X(TOT)=" A total of "_CNT4_" Allowable Qualifier"_$SELECT(CNT4=1:" was",1:"s were")_" added."
- End DoDot:1
- +25 IF PROBLEM>0
- Begin DoDot:1
- +26 SET TOT=TOT+1
- SET X(TOT)=" Contact Customer Support for assistance updating the package interface file."
- End DoDot:1
- +27 ;
- +28 if TALK
- DO MES^XPDUTL(.X)
- +29 ;
- END KILL ^TMP($JOB,"IBDE CLN")
- +1 QUIT
- +2 ;
- DEL(TALK,PI,J,K,REASON,NNODE,ONODE) ; -- delete inappropriate entries
- +1 ;
- +2 ; reasons for deletion or warnings
- +3 ; 1- invalid qualifier
- +4 ; 2- duplicate qualifier
- +5 ; 9- bad qualifier, not deleted, user warned
- +6 ; 20-node ^IBE(357.6,IEN,12) not correct
- +7 ; 21-node ^IBE(357.6,IEN,13,allow qual,0) not correct
- +8 ;
- +9 NEW I,X,Y,DA,DIC,DIK
- +10 IF (REASON=1!(REASON=2))
- SET CNT=CNT+1
- +11 SET CNT(PI)=+$GET(CNT(PI))+1
- +12 IF CNT(PI)=1
- Begin DoDot:1
- +13 SET X(1)=" "
- SET X(2)=" The Package Interface "_PI_" had: "
- +14 if TALK
- DO MES^XPDUTL(.X)
- NEW X
- End DoDot:1
- +15 if (TALK&(REASON=1))
- DO MES^XPDUTL(" an invalid qualifier of "_QLF_" deleted.")
- +16 if (TALK&(REASON=2))
- DO MES^XPDUTL(" a duplicate qualifier of "_QLF_" deleted.")
- +17 ;don't delete, save for manual update
- IF TALK&(REASON=9)
- DO MES^XPDUTL(" a bad qualifier of "_QLF_" not deleted, PCE DIM NODE='PROBLEM'")
- QUIT
- +18 ;
- +19 IF REASON<10
- SET DA=K
- SET DA(1)=J
- SET DIK="^IBE(357.6,"_DA(1)_",13,"
- DO ^DIK
- QUIT
- +20 ;
- +21 IF TALK&(REASON=20)
- Begin DoDot:1
- +22 NEW X
- +23 SET X(1)=" The PCE Device Interface Data Updated."
- +24 SET X(2)=" Old Data: "_ONODE
- +25 SET X(3)=" New Data: "_NNODE
- +26 if TALK
- DO MES^XPDUTL(.X)
- +27 SET CNT2=CNT2+1
- +28 SET ^IBE(357.6,J,12)=NNODE
- End DoDot:1
- +29 ;
- +30 IF TALK&(REASON=21)
- Begin DoDot:1
- +31 NEW X
- +32 SET X(1)=" The PCE Device Interface Data for the Data Qualifier "_QLF_" was updated."
- +33 SET X(2)=" Old Data: "_ONODE
- +34 SET X(3)=" New Data: "_NNODE
- +35 if TALK
- DO MES^XPDUTL(.X)
- +36 SET CNT3=CNT3+1
- +37 SET ^IBE(357.6,J,13,K,0)=NNODE
- End DoDot:1
- +38 ;
- +39 IF TALK&(REASON=22)
- Begin DoDot:1
- +40 SET CNT4=CNT4+1
- +41 DO MES^XPDUTL(" "_QLF_" was added.")
- +42 SET ^IBE(357.6,J,13,K,0)=NNODE
- End DoDot:1
- +43 QUIT
- +44 ;
- CLNQLF(TALK) ;
- +1 ; -- update codes in AICS DATA QUALIFIERS file (357.98)
- +2 ; according to version 3.0
- +3 NEW I,J,K,L,X,Y,CNT,CNT1,CNT2,CNT3,ENTRY,NAME,CODE,NEWNAME,IBQUIT,DIC,DIE,DIK,DA,DR
- +4 SET (CNT,CNT1)=0
- SET CNT2=1
- +5 ;
- +6 SET (X(1),X(3))=" "
- +7 SET X(2)=">>> Now checking the AICS DATA QUALIFIERS file for inappropriate entries."
- +8 if TALK
- DO MES^XPDUTL(.X)
- +9 ;
- +10 ; -- Go through AICS Data Qualifiers and set up correctly
- +11 FOR I=1:1:28
- SET ENTRY=$PIECE($TEXT(DATA+I),";;",2)
- if ENTRY=""
- QUIT
- Begin DoDot:1
- +12 SET CNT=CNT+1
- +13 SET NAME=$PIECE(ENTRY,"^",1)
- +14 SET CODE=$PIECE(ENTRY,"^",2)
- +15 SET J=""
- +16 FOR
- SET J=$ORDER(^IBD(357.98,"B",NAME,J))
- if J=""
- QUIT
- Begin DoDot:2
- +17 IF $PIECE($GET(^IBD(357.98,J,0)),"^",2)=CODE
- QUIT
- +18 ;
- +19 ; -- don't change Active=1 and Inactive=0 if Problem
- +20 IF $PIECE($GET(^IBE(357.6,J,12)),"^",1)="PROBLEM"
- IF NAME="ACTIVE"!(NAME="INACTIVE")
- Begin DoDot:3
- +21 SET IBQUIT=0
- +22 IF NAME="ACTIVE"
- IF ($PIECE($GET(^IBD(357.98,J,0)),"^",2)=1)
- Begin DoDot:4
- +23 SET IBQUIT=1
- +24 DO MES^XPDUTL(" The qualifier ACTIVE with a code of 1 needs to be changed but is used.")
- End DoDot:4
- +25 IF NAME="INACTIVE"
- IF ($PIECE($GET(^IBD(357.98,J,0)),"^",2)=0)
- Begin DoDot:4
- +26 SET IBQUIT=1
- +27 DO MES^XPDUTL(" The qualifier of INACTIVE with a code of 0 needs to be changed but is used.")
- End DoDot:4
- End DoDot:3
- if IBQUIT
- QUIT
- +28 +29 ; -- keep track of what was changed
- +30 SET CNT(NAME)=$GET(CNT(NAME))+1
- +31 SET CNT1=CNT1+1
- SET CNT2=CNT2+1
- +32 SET CNT3(CNT2)=" The Entry "_$GET(^IBD(357.98,J,0))_" changed to ZZBAD-"_ENTRY
- +33 ;
- +34 ; -- see if it's used
- +35 SET K=0
- FOR
- SET K=$ORDER(^IBE(357.6,K))
- if 'K
- QUIT
- IF $DATA(^IBE(357.6,K,13))
- Begin DoDot:3
- +36 SET L=0
- FOR
- SET L=$ORDER(^IBE(357.6,K,13,L))
- if 'L
- QUIT
- IF $PIECE($GET(^IBE(357.6,K,13,L,0)),"^",1)=(J_";IBD(357.98,")
- Begin DoDot:4
- +37 SET CNT2=CNT2+1
- +38 SET CNT3(CNT2)=" and was used by Package File entry "_$PIECE($GET(^IBE(357.6,K,0)),"^",1)
- End DoDot:4
- End DoDot:3
- +39 ;
- +40 ; -- finally, make the change
- +41 SET NEWNAME=$EXTRACT("ZZBAD-"_$PIECE(^IBD(357.98,J,0),"^",1),1,30)
- +42 SET DIE="^IBD(357.98,"
- SET DA=J
- SET DR=".01////^S X=NEWNAME;.02////^S X=CODE"
- +43 NEW I,J,K,L,X,Y
- DO ^DIE
- KILL DIE,DA,DR
- End DoDot:2
- End DoDot:1
- +44 ;
- +45 ;
- +46 ; -- reindex the file
- +47 SET DIK="^IBD(357.98,"
- +48 DO IXALL^DIK
- +49 ;
- +50 ; summary of the aics data qualifiers check
- +51 ;
- +52 KILL X
- +53 SET X(1)=" "
- SET X(2)=" >> Summary of the AICS Data Qualifiers Check:"
- +54 if TALK
- DO MES^XPDUTL(.X)
- +55 KILL X
- +56 IF $GET(CNT1)>0
- MERGE X=CNT3
- SET X(1)=" The number of changes made was "_CNT1
- +57 IF CNT1=0
- SET X(1)=" No required changes were found."
- SET X(2)=" "
- +58 IF CNT1>1
- SET (X(CNT2+1),X(CNT2+3))=" "
- SET X(CNT2+2)=" >> Done updating the AICS DATA QUALIFIERS file"
- +59 if TALK
- DO MES^XPDUTL(.X)
- +60 QUIT
- +61 ;
- DATA ;;
- +1 ;;NONE APPLICABLE^
- +2 ;;PRIMARY^P^P
- +3 ;;SECONDARY^S^S
- +4 ;;ACTIVE^A^A
- +5 ;;INACTIVE^I^I
- +6 ;;HISTORICAL^H
- +7 ;;ADD TO PROBLEM LIST^1^ADD
- +8 ;;SERVICE CONNECTED^1^SC
- +9 ;;AGENT ORANGE RELATED^1^AO
- +10 ;;IONIZING RADIATION RELATED^1^IR
- +11 ;;ENVIRONMENTAL CONTAMINANTS RELATED^1^EC
- +12 ;;MILITARY SEXUAL TRAUMA^1^MST
- +13 ;;ABNORMAL RESULT^A^ABNORM
- +14 ;;NORMAL RESULT^N^NORM
- +15 ;;POOR UNDERSTANDING^1^POOR
- +16 ;;FAIR UNDERSTANDING^2^FAIR
- +17 ;;GOOD UNDERSTANDING^3^GOOD
- +18 ;;UNDERSTANDING NOT ASSESSED^4^N/A
- +19 ;;PATIENT ED REFUSED^5^REFUSED
- +20 ;;MINIMAL SEVERITY^M^MINIMAL
- +21 ;;MODERATE SEVERITY^MO^MODERATE
- +22 ;;HEAVY SEVERITY^H^SEVERE
- +23 ;;YES^1^YES
- +24 ;;NO^0^NO
- +25 ;;CONTRAINDICATED^1^CONTRA.
- +26 ;;GIVEN^0^GIV
- +27 ;;REFUSED^1^REFUSED
- +28 ;;NON-SERVICE CONNECTED^0^NSC
- +29 ;;NO CLASSIFICATIONS^1^NO CLASSIF
- +30 ;;