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 Dec 13, 2024@01:38:52 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 ;;
