IBDECLN1 ;ALB/AAS - Clean up Data Qualifiers and Package interfaces ; 23-JUN-97
;;3.0;AUTOMATED INFO COLLECTION SYS;**14**;APR 24, 1997
;
PROBLEM(PROBLEM) ; -- Find out if Problem is in PCE DIM NODE in 357.6
;
; pce dim node should not equal problem
N I,J
S I=0,PROBLEM=0
F S I=$O(^IBE(357.6,I)) Q:'I D
. I $P($G(^IBE(357.6,I,12)),"^",1)="PROBLEM" D
.. S PROBLEM=PROBLEM+1
.. S PROBLEM(0,I)=""
.. S PROBLEM(PROBLEM)=$P($G(^IBE(357.6,I,0)),"^",1)_" uses PROBLEM as the PCE DIM NODE"
. S J=0
. F S J=$O(^IBE(357.6,I,13,J)) Q:'J D
.. I $P($G(^IBE(357.6,I,13,J,0)),"^",4)="PROBLEM" D
... S PROBLEM=PROBLEM+1
... S PROBLEM(0,I)=""
... S PROBLEM(PROBLEM)=$P($G(^IBE(357.6,I,0)),"^",1)_" uses PROBLEM as the PCE DIM NODE in the Allow. Qual. Multiple."
;
Q
;
CLNSEL(TALK) ; -- Clean up selection list entries
; -- should be run after running clnqlf, will update the zzbad pointers
;
N I,J,K,L,X,Y,CNT,CNT1,CNT2,NAME,QLF,QLFNAM,PI,PINAM,PINPUT,REALQLF,REALNAM,PROBLEM,SELNAM,BLKNAM,IBQUIT,DIC,DIE,DIK,DA,DR,FRM,FRMNAM,FRMTYPE
S (CNT,CNT1,CNT2)=0
;
D:TALK MES^XPDUTL(" ")
D:TALK MES^XPDUTL(">>> Now checking the SELECTION LIST file for inappropriate Data Qualifiers.")
;
; -- Find out if Problem is in PCE DIM NODE in 357.6
D PROBLEM(.PROBLEM)
;
; -- go through selection list file look at data qualifiers in
; subcolumn multiple fields
S I=0
F S I=$O(^IBE(357.2,I)) Q:'I D
. S CNT=CNT+1
. S SELNAM=$P($G(^IBE(357.2,I,0)),"^",1)
. S BLKNAM=$P($G(^IBE(357.1,+$P($G(^IBE(357.2,I,0)),"^",2),0)),"^",1)
. S FRM=+$P($G(^IBE(357.1,+$P($G(^IBE(357.2,I,0)),"^",2),0)),"^",2)
. S FRMNAM=$P($G(^IBE(357,+FRM,0)),"^",1)
. S FRMTYPE=$P($G(^IBE(357,+FRM,0)),"^",13)
. S PI=+$P($G(^IBE(357.2,I,0)),"^",11)
. S PINPUT=+$P($G(^IBE(357.6,PI,0)),"^",13)
. S PINAM=$P($G(^IBE(357.6,+$P($G(^IBE(357.2,I,0)),"^",11),0)),"^",1)
. ;
. S J=0
. F S J=$O(^IBE(357.2,I,2,J)) Q:'J D
.. S QLF=+$P($G(^IBE(357.2,I,2,J,0)),"^",9)
.. Q:'QLF
.. S QLFNAM=$P($G(^IBD(357.98,QLF,0)),"^",1)
.. ;
.. Q:$E(QLFNAM,1,6)'="ZZBAD-"
.. S CNT1=CNT1+1
.. S REALNAM=$P(QLFNAM,"ZZBAD-",2)
.. Q:REALNAM=""
.. S REALQLF=+$O(^IBD(357.98,"B",REALNAM,0))
.. Q:'REALQLF
..;
..; -- don't change if uses Problem node
.. I PROBLEM>0 I $D(PROBLEM(0,PI))!($D(PROBLEM(0,PINPUT))) D Q
... D MES^XPDUTL(" ")
... D MES^XPDUTL(" >> The selection list "_SELNAM_" not updated, PCE DIM node set to PROBLEM")
..
..; -- now update the selection list to the real qualifier
.. S CNT2=CNT2+1
.. S $P(^IBE(357.2,I,2,J,0),"^",9)=REALQLF
..;
..D:TALK MESSAGE
;
; -- write out summary
K X
S X(1)=" ",X(2)=" >> Summary of Selection List Check:"
D:TALK MES^XPDUTL(.X)
K X
S X(1)=" "
S X(2)=" >> A total of "_CNT_" selection list"_$S(CNT=1:" was",1:"s were")_" checked."
I CNT1=0 S X(3)=" No problems were found."
I CNT1>0 S X(3)=" A total of "_CNT1_" problem"_$S(CNT1=1:" was",1:"s were")_" found and "_CNT2_" were corrected."
D:TALK MES^XPDUTL(.X)
Q
;
MESSAGE ; -- write out what happened
N K,X,CLIN,CLNLST
S CLNLST=""
S CLIN="^TMP(""CLST"",$J)"
D CLINICS^IBDFU4(FRM,CLIN)
S X(1)=" "
S X(2)=">>> Qualifier problem in Encounter form "_FRMNAM
I FRMTYPE S X(2)=X(2)_" Number "_FRMTYPE
I @CLIN@(0)=0 S X(3)=" This form was not used by clinics"
I @CLIN@(0)>0 D
. S X(3)=" This form is used in the following clinics:"
. S K=0,J=3 F S K=$O(@CLIN@(K)) Q:K="" S CLNLST=CLNLST_", "_K D
. . Q:$L(CLNLST)>55
. . S J=J+1,X(J)=" "_CLNLST
. . S CLNLST=""
S X(J+1)=" In the "_BLKNAM_" Block"
S X(J+2)=" In the "_SELNAM_" Selection List"
S X(J+3)=" the qualifier of "_QLFNAM_" Changed to "_REALNAM
D:TALK MES^XPDUTL(.X)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDECLN1 3778 printed Dec 13, 2024@01:38:53 Page 2
IBDECLN1 ;ALB/AAS - Clean up Data Qualifiers and Package interfaces ; 23-JUN-97
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**14**;APR 24, 1997
+2 ;
PROBLEM(PROBLEM) ; -- Find out if Problem is in PCE DIM NODE in 357.6
+1 ;
+2 ; pce dim node should not equal problem
+3 NEW I,J
+4 SET I=0
SET PROBLEM=0
+5 FOR
SET I=$ORDER(^IBE(357.6,I))
if 'I
QUIT
Begin DoDot:1
+6 IF $PIECE($GET(^IBE(357.6,I,12)),"^",1)="PROBLEM"
Begin DoDot:2
+7 SET PROBLEM=PROBLEM+1
+8 SET PROBLEM(0,I)=""
+9 SET PROBLEM(PROBLEM)=$PIECE($GET(^IBE(357.6,I,0)),"^",1)_" uses PROBLEM as the PCE DIM NODE"
End DoDot:2
+10 SET J=0
+11 FOR
SET J=$ORDER(^IBE(357.6,I,13,J))
if 'J
QUIT
Begin DoDot:2
+12 IF $PIECE($GET(^IBE(357.6,I,13,J,0)),"^",4)="PROBLEM"
Begin DoDot:3
+13 SET PROBLEM=PROBLEM+1
+14 SET PROBLEM(0,I)=""
+15 SET PROBLEM(PROBLEM)=$PIECE($GET(^IBE(357.6,I,0)),"^",1)_" uses PROBLEM as the PCE DIM NODE in the Allow. Qual. Multiple."
End DoDot:3
End DoDot:2
End DoDot:1
+16 ;
+17 QUIT
+18 ;
CLNSEL(TALK) ; -- Clean up selection list entries
+1 ; -- should be run after running clnqlf, will update the zzbad pointers
+2 ;
+3 NEW I,J,K,L,X,Y,CNT,CNT1,CNT2,NAME,QLF,QLFNAM,PI,PINAM,PINPUT,REALQLF,REALNAM,PROBLEM,SELNAM,BLKNAM,IBQUIT,DIC,DIE,DIK,DA,DR,FRM,FRMNAM,FRMTYPE
+4 SET (CNT,CNT1,CNT2)=0
+5 ;
+6 if TALK
DO MES^XPDUTL(" ")
+7 if TALK
DO MES^XPDUTL(">>> Now checking the SELECTION LIST file for inappropriate Data Qualifiers.")
+8 ;
+9 ; -- Find out if Problem is in PCE DIM NODE in 357.6
+10 DO PROBLEM(.PROBLEM)
+11 ;
+12 ; -- go through selection list file look at data qualifiers in
+13 ; subcolumn multiple fields
+14 SET I=0
+15 FOR
SET I=$ORDER(^IBE(357.2,I))
if 'I
QUIT
Begin DoDot:1
+16 SET CNT=CNT+1
+17 SET SELNAM=$PIECE($GET(^IBE(357.2,I,0)),"^",1)
+18 SET BLKNAM=$PIECE($GET(^IBE(357.1,+$PIECE($GET(^IBE(357.2,I,0)),"^",2),0)),"^",1)
+19 SET FRM=+$PIECE($GET(^IBE(357.1,+$PIECE($GET(^IBE(357.2,I,0)),"^",2),0)),"^",2)
+20 SET FRMNAM=$PIECE($GET(^IBE(357,+FRM,0)),"^",1)
+21 SET FRMTYPE=$PIECE($GET(^IBE(357,+FRM,0)),"^",13)
+22 SET PI=+$PIECE($GET(^IBE(357.2,I,0)),"^",11)
+23 SET PINPUT=+$PIECE($GET(^IBE(357.6,PI,0)),"^",13)
+24 SET PINAM=$PIECE($GET(^IBE(357.6,+$PIECE($GET(^IBE(357.2,I,0)),"^",11),0)),"^",1)
+25 ;
+26 SET J=0
+27 FOR
SET J=$ORDER(^IBE(357.2,I,2,J))
if 'J
QUIT
Begin DoDot:2
+28 SET QLF=+$PIECE($GET(^IBE(357.2,I,2,J,0)),"^",9)
+29 if 'QLF
QUIT
+30 SET QLFNAM=$PIECE($GET(^IBD(357.98,QLF,0)),"^",1)
+31 ;
+32 if $EXTRACT(QLFNAM,1,6)'="ZZBAD-"
QUIT
+33 SET CNT1=CNT1+1
+34 SET REALNAM=$PIECE(QLFNAM,"ZZBAD-",2)
+35 if REALNAM=""
QUIT
+36 SET REALQLF=+$ORDER(^IBD(357.98,"B",REALNAM,0))
+37 if 'REALQLF
QUIT
+38 ;
+39 ; -- don't change if uses Problem node
+40 IF PROBLEM>0
IF $DATA(PROBLEM(0,PI))!($DATA(PROBLEM(0,PINPUT)))
Begin DoDot:3
+41 DO MES^XPDUTL(" ")
+42 DO MES^XPDUTL(" >> The selection list "_SELNAM_" not updated, PCE DIM node set to PROBLEM")
End DoDot:3
QUIT
+43 +44 ; -- now update the selection list to the real qualifier
+45 SET CNT2=CNT2+1
+46 SET $PIECE(^IBE(357.2,I,2,J,0),"^",9)=REALQLF
+47 ;
+48 if TALK
DO MESSAGE
End DoDot:2
End DoDot:1
+49 ;
+50 ; -- write out summary
+51 KILL X
+52 SET X(1)=" "
SET X(2)=" >> Summary of Selection List Check:"
+53 if TALK
DO MES^XPDUTL(.X)
+54 KILL X
+55 SET X(1)=" "
+56 SET X(2)=" >> A total of "_CNT_" selection list"_$SELECT(CNT=1:" was",1:"s were")_" checked."
+57 IF CNT1=0
SET X(3)=" No problems were found."
+58 IF CNT1>0
SET X(3)=" A total of "_CNT1_" problem"_$SELECT(CNT1=1:" was",1:"s were")_" found and "_CNT2_" were corrected."
+59 if TALK
DO MES^XPDUTL(.X)
+60 QUIT
+61 ;
MESSAGE ; -- write out what happened
+1 NEW K,X,CLIN,CLNLST
+2 SET CLNLST=""
+3 SET CLIN="^TMP(""CLST"",$J)"
+4 DO CLINICS^IBDFU4(FRM,CLIN)
+5 SET X(1)=" "
+6 SET X(2)=">>> Qualifier problem in Encounter form "_FRMNAM
+7 IF FRMTYPE
SET X(2)=X(2)_" Number "_FRMTYPE
+8 IF @CLIN@(0)=0
SET X(3)=" This form was not used by clinics"
+9 IF @CLIN@(0)>0
Begin DoDot:1
+10 SET X(3)=" This form is used in the following clinics:"
+11 SET K=0
SET J=3
FOR
SET K=$ORDER(@CLIN@(K))
if K=""
QUIT
SET CLNLST=CLNLST_", "_K
Begin DoDot:2
+12 if $LENGTH(CLNLST)>55
QUIT
+13 SET J=J+1
SET X(J)=" "_CLNLST
+14 SET CLNLST=""
End DoDot:2
End DoDot:1
+15 SET X(J+1)=" In the "_BLKNAM_" Block"
+16 SET X(J+2)=" In the "_SELNAM_" Selection List"
+17 SET X(J+3)=" the qualifier of "_QLFNAM_" Changed to "_REALNAM
+18 if TALK
DO MES^XPDUTL(.X)
+19 QUIT
