MCARVCHK ;HIRMFO/DAD-MEDICINE VIEW FILE SANITY CHECK ;5/23/96 11:09
;;2.3;Medicine;;09/13/1996
;
K %ZIS,IOP S %ZIS="QM" W ! D ^%ZIS G:POP EXIT
I $D(IO("Q")) D G EXIT
. S ZTRTN="TASK^MCARVCHK"
. S ZTDESC="Medicine View file (#690.2) sanity check report"
. D ^%ZTLOAD
. Q
TASK ;
K ^TMP("MCARVCHK",$J)
S (MCD0,MCERR)=0
F S MCD0=$O(^MCAR(690.2,MCD0)) Q:MCD0'>0 D MAIN
PRINT ;
U IO K MCUNDL
S MCEXIT=0,MCPAGE=1,$P(MCUNDL,"-",81)=""
S MCTODAY=$$FMTE^XLFDT(DT)
D HEADER
I $O(^TMP("MCARVCHK",$J,0))'>0 D G EXIT
. W !!,"NO PROBLEMS FOUND"
. Q
S MCERR=0
F S MCERR=$O(^TMP("MCARVCHK",$J,MCERR)) Q:MCERR'>0!MCEXIT D
. S MCDATA=^TMP("MCARVCHK",$J,MCERR)
. S MCNAME=$P(MCDATA,U),MCFILE=$P(MCDATA,U,2),MCTEXT=$P(MCDATA,U,3)
. W !!,MCNAME,?70,MCFILE,!?5,MCTEXT
. I $Y>(IOSL-4) D PAUSE,HEADER
. Q
EXIT ;
D ^%ZISC
S:$D(ZTQUEUED) ZTREQ="@"
K %ZIS,DIR,DIROUT,DIRUT,DTOUT,DUOUT,MCD0,MCD1,MCD2,MCDATA,MCERR,MCEXIT
K MCFIELD,MCFILE,MCFL,MCNAME,MCPAGE,MCSUBFIL,MCSUBFLD,MCTEXT,MCTODAY
K MCUNDL,MCUP,MCZERO,POP,X,Y,ZTDESC,ZTRTN,^TMP("MCARVCHK",$J)
Q
MAIN ;
K ^TMP("MCSUB",$J)
S MCZERO=$G(^MCAR(690.2,MCD0,0))
S MCNAME=$P(MCZERO,U),MCFILE=+$P(MCZERO,U,2)
;
; *** Check the Primary File ***
;
I $$VFILE^DILFD(MCFILE)'>0 D Q
. D ERR("Primary file # "_MCFILE_" does not exist")
. Q
;
; *** Check the Field mult ***
;
I $O(^MCAR(690.2,MCD0,1,0))'>0 D
. D ERR("No Fields specified")
. Q
S MCD1=0
F S MCD1=$O(^MCAR(690.2,MCD0,1,MCD1)) Q:MCD1'>0 D
. S MCFIELD=$P($G(^MCAR(690.2,MCD0,1,MCD1,0)),U)
. I $$VFIELD^DILFD(MCFILE,MCFIELD)'>0 D Q
.. D ERR("Field # "_MCFILE_","_MCFIELD_" does not exist")
.. Q
. S MCSUBFIL=+$$GET1^DID(MCFILE,MCFIELD,"","SPECIFIER")
. I MCSUBFIL D
.. S MC=($O(^DD(MCSUBFIL,.01))'>0)&($D(^DD(MCSUBFIL,.01,0))#2)
.. S MCTEXT="Field # "_MCFILE_","_MCFIELD_" missing Sub-File/Field"
.. S MCTEXT=MCTEXT_" # "_MCSUBFIL_","_$S(MC:".01",1:"???")
.. S ^TMP("MCSUB",$J,MCSUBFIL)=MCTEXT
.. Q
. Q
;
; *** Check the Sub-Field mult ***
;
S MCD1=0
F S MCD1=$O(^MCAR(690.2,MCD0,2,MCD1)) Q:MCD1'>0 D
. S MCSUBFIL=+$P($G(^MCAR(690.2,MCD0,2,MCD1,0)),U)
. I $G(^DD(MCSUBFIL,0))="" Q
. I $O(^MCAR(690.2,MCD0,2,MCD1,1,0))'>0 D
.. D ERR("No Sub-Fields specified for Sub-File # "_MCSUBFIL)
.. Q
. S MCD2=0
. F S MCD2=$O(^MCAR(690.2,MCD0,2,MCD1,1,MCD2)) Q:MCD2'>0 D
.. S MCSUBFLD=+$P($G(^MCAR(690.2,MCD0,2,MCD1,1,MCD2,0)),U)
.. I $$VFIELD^DILFD(MCSUBFIL,MCSUBFLD)'>0 D Q
... D ERR("Sub-Field # "_MCSUBFIL_","_MCSUBFLD_" does not exist")
... Q
.. S MCSUBFIL(0)=+$$GET1^DID(MCSUBFIL,MCSUBFLD,"","SPECIFIER")
.. I MCSUBFIL(0)>0 D
... S MC=($O(^DD(MCSUBFIL(0),.01))'>0)&($D(^DD(MCSUBFIL(0),.01,0))#2)
... S MCTEXT="Sub-Field # "_MCSUBFIL_","_MCSUBFLD_" missing Sub-File/"
... S MCTEXT=MCTEXT_"Field # "_MCSUBFIL(0)_","_$S(MC:".01",1:"???")
... S ^TMP("MCSUB",$J,MCSUBFIL(0))=MCTEXT
... Q
.. Q
. Q
;
; *** Check the Sub-File mult ***
;
I $O(^TMP("MCSUB",$J,0)),$O(^MCAR(690.2,MCD0,2,0))'>0 D
. D ERR("No Sub-Files specified")
. Q
S MCD1=0
F S MCD1=$O(^MCAR(690.2,MCD0,2,MCD1)) Q:MCD1'>0 D
. S MCSUBFIL=+$P($G(^MCAR(690.2,MCD0,2,MCD1,0)),U)
. I $G(^DD(MCSUBFIL,0))="" D Q
.. D ERR("Subfile # "_MCSUBFIL_" does not exist")
.. Q
. I $D(^TMP("MCSUB",$J,MCSUBFIL)) D
.. K ^TMP("MCSUB",$J,MCSUBFIL)
.. Q
. E D
.. S MCUP=+$G(^DD(MCSUBFIL,0,"UP"))
.. S MCUP=$S(MCUP:MCUP,1:"???")
.. S MCFL=+$O(^DD(MCUP,"SB",MCSUBFIL,0))
.. S MCFL=$S(MCFL:MCFL,1:"???")
.. S MCTEXT="Sub-File # "_MCSUBFIL_" is missing "
.. S MCTEXT=MCTEXT_$S(MCUP'=MCFILE:"Sub-",1:"")
.. S MCTEXT=MCTEXT_"File/Field # "_MCUP_","_MCFL
.. S ^TMP("MCSUB",$J,MCSUBFIL)=MCTEXT
.. Q
. Q
;
S MCSUBFIL=0
F S MCSUBFIL=$O(^TMP("MCSUB",$J,MCSUBFIL)) Q:MCSUBFIL'>0 D
. D ERR(^TMP("MCSUB",$J,MCSUBFIL))
. Q
K ^TMP("MCSUB",$J)
Q
ERR(X) ;
S MCERR=MCERR+1
S ^TMP("MCARVCHK",$J,MCERR)=MCNAME_U_MCD0_U_X
Q
PAUSE ;
I $E(IOST,1,2)="C-" D
. N DIR S DIR(0)="E" D ^DIR S MCEXIT=$S(Y'>0:1,1:0)
. Q
E D
. S MCEXIT=0
. Q
Q
I MCEXIT Q
I ($E(IOST,1,2)="C-")!(MCPAGE>1) W @IOF
W !?25,"MEDICINE VIEW FILE SANITY CHECK",?68,MCTODAY
W !?68,"PAGE: ",MCPAGE S MCPAGE=MCPAGE+1
W !,"PRINT VIEW TEMPLATE NAME",?70,"IEN",!?5,"ERROR MESSAGE"
W !,MCUNDL
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCARVCHK 4346 printed Apr 09, 2024@21:19:29 Page 2
MCARVCHK ;HIRMFO/DAD-MEDICINE VIEW FILE SANITY CHECK ;5/23/96 11:09
+1 ;;2.3;Medicine;;09/13/1996
+2 ;
+3 KILL %ZIS,IOP
SET %ZIS="QM"
WRITE !
DO ^%ZIS
if POP
GOTO EXIT
+4 IF $DATA(IO("Q"))
Begin DoDot:1
+5 SET ZTRTN="TASK^MCARVCHK"
+6 SET ZTDESC="Medicine View file (#690.2) sanity check report"
+7 DO ^%ZTLOAD
+8 QUIT
End DoDot:1
GOTO EXIT
TASK ;
+1 KILL ^TMP("MCARVCHK",$JOB)
+2 SET (MCD0,MCERR)=0
+3 FOR
SET MCD0=$ORDER(^MCAR(690.2,MCD0))
if MCD0'>0
QUIT
DO MAIN
PRINT ;
+1 USE IO
KILL MCUNDL
+2 SET MCEXIT=0
SET MCPAGE=1
SET $PIECE(MCUNDL,"-",81)=""
+3 SET MCTODAY=$$FMTE^XLFDT(DT)
+4 DO HEADER
+5 IF $ORDER(^TMP("MCARVCHK",$JOB,0))'>0
Begin DoDot:1
+6 WRITE !!,"NO PROBLEMS FOUND"
+7 QUIT
End DoDot:1
GOTO EXIT
+8 SET MCERR=0
+9 FOR
SET MCERR=$ORDER(^TMP("MCARVCHK",$JOB,MCERR))
if MCERR'>0!MCEXIT
QUIT
Begin DoDot:1
+10 SET MCDATA=^TMP("MCARVCHK",$JOB,MCERR)
+11 SET MCNAME=$PIECE(MCDATA,U)
SET MCFILE=$PIECE(MCDATA,U,2)
SET MCTEXT=$PIECE(MCDATA,U,3)
+12 WRITE !!,MCNAME,?70,MCFILE,!?5,MCTEXT
+13 IF $Y>(IOSL-4)
DO PAUSE
DO HEADER
+14 QUIT
End DoDot:1
EXIT ;
+1 DO ^%ZISC
+2 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 KILL %ZIS,DIR,DIROUT,DIRUT,DTOUT,DUOUT,MCD0,MCD1,MCD2,MCDATA,MCERR,MCEXIT
+4 KILL MCFIELD,MCFILE,MCFL,MCNAME,MCPAGE,MCSUBFIL,MCSUBFLD,MCTEXT,MCTODAY
+5 KILL MCUNDL,MCUP,MCZERO,POP,X,Y,ZTDESC,ZTRTN,^TMP("MCARVCHK",$JOB)
+6 QUIT
MAIN ;
+1 KILL ^TMP("MCSUB",$JOB)
+2 SET MCZERO=$GET(^MCAR(690.2,MCD0,0))
+3 SET MCNAME=$PIECE(MCZERO,U)
SET MCFILE=+$PIECE(MCZERO,U,2)
+4 ;
+5 ; *** Check the Primary File ***
+6 ;
+7 IF $$VFILE^DILFD(MCFILE)'>0
Begin DoDot:1
+8 DO ERR("Primary file # "_MCFILE_" does not exist")
+9 QUIT
End DoDot:1
QUIT
+10 ;
+11 ; *** Check the Field mult ***
+12 ;
+13 IF $ORDER(^MCAR(690.2,MCD0,1,0))'>0
Begin DoDot:1
+14 DO ERR("No Fields specified")
+15 QUIT
End DoDot:1
+16 SET MCD1=0
+17 FOR
SET MCD1=$ORDER(^MCAR(690.2,MCD0,1,MCD1))
if MCD1'>0
QUIT
Begin DoDot:1
+18 SET MCFIELD=$PIECE($GET(^MCAR(690.2,MCD0,1,MCD1,0)),U)
+19 IF $$VFIELD^DILFD(MCFILE,MCFIELD)'>0
Begin DoDot:2
+20 DO ERR("Field # "_MCFILE_","_MCFIELD_" does not exist")
+21 QUIT
End DoDot:2
QUIT
+22 SET MCSUBFIL=+$$GET1^DID(MCFILE,MCFIELD,"","SPECIFIER")
+23 IF MCSUBFIL
Begin DoDot:2
+24 SET MC=($ORDER(^DD(MCSUBFIL,.01))'>0)&($DATA(^DD(MCSUBFIL,.01,0))#2)
+25 SET MCTEXT="Field # "_MCFILE_","_MCFIELD_" missing Sub-File/Field"
+26 SET MCTEXT=MCTEXT_" # "_MCSUBFIL_","_$SELECT(MC:".01",1:"???")
+27 SET ^TMP("MCSUB",$JOB,MCSUBFIL)=MCTEXT
+28 QUIT
End DoDot:2
+29 QUIT
End DoDot:1
+30 ;
+31 ; *** Check the Sub-Field mult ***
+32 ;
+33 SET MCD1=0
+34 FOR
SET MCD1=$ORDER(^MCAR(690.2,MCD0,2,MCD1))
if MCD1'>0
QUIT
Begin DoDot:1
+35 SET MCSUBFIL=+$PIECE($GET(^MCAR(690.2,MCD0,2,MCD1,0)),U)
+36 IF $GET(^DD(MCSUBFIL,0))=""
QUIT
+37 IF $ORDER(^MCAR(690.2,MCD0,2,MCD1,1,0))'>0
Begin DoDot:2
+38 DO ERR("No Sub-Fields specified for Sub-File # "_MCSUBFIL)
+39 QUIT
End DoDot:2
+40 SET MCD2=0
+41 FOR
SET MCD2=$ORDER(^MCAR(690.2,MCD0,2,MCD1,1,MCD2))
if MCD2'>0
QUIT
Begin DoDot:2
+42 SET MCSUBFLD=+$PIECE($GET(^MCAR(690.2,MCD0,2,MCD1,1,MCD2,0)),U)
+43 IF $$VFIELD^DILFD(MCSUBFIL,MCSUBFLD)'>0
Begin DoDot:3
+44 DO ERR("Sub-Field # "_MCSUBFIL_","_MCSUBFLD_" does not exist")
+45 QUIT
End DoDot:3
QUIT
+46 SET MCSUBFIL(0)=+$$GET1^DID(MCSUBFIL,MCSUBFLD,"","SPECIFIER")
+47 IF MCSUBFIL(0)>0
Begin DoDot:3
+48 SET MC=($ORDER(^DD(MCSUBFIL(0),.01))'>0)&($DATA(^DD(MCSUBFIL(0),.01,0))#2)
+49 SET MCTEXT="Sub-Field # "_MCSUBFIL_","_MCSUBFLD_" missing Sub-File/"
+50 SET MCTEXT=MCTEXT_"Field # "_MCSUBFIL(0)_","_$SELECT(MC:".01",1:"???")
+51 SET ^TMP("MCSUB",$JOB,MCSUBFIL(0))=MCTEXT
+52 QUIT
End DoDot:3
+53 QUIT
End DoDot:2
+54 QUIT
End DoDot:1
+55 ;
+56 ; *** Check the Sub-File mult ***
+57 ;
+58 IF $ORDER(^TMP("MCSUB",$JOB,0))
IF $ORDER(^MCAR(690.2,MCD0,2,0))'>0
Begin DoDot:1
+59 DO ERR("No Sub-Files specified")
+60 QUIT
End DoDot:1
+61 SET MCD1=0
+62 FOR
SET MCD1=$ORDER(^MCAR(690.2,MCD0,2,MCD1))
if MCD1'>0
QUIT
Begin DoDot:1
+63 SET MCSUBFIL=+$PIECE($GET(^MCAR(690.2,MCD0,2,MCD1,0)),U)
+64 IF $GET(^DD(MCSUBFIL,0))=""
Begin DoDot:2
+65 DO ERR("Subfile # "_MCSUBFIL_" does not exist")
+66 QUIT
End DoDot:2
QUIT
+67 IF $DATA(^TMP("MCSUB",$JOB,MCSUBFIL))
Begin DoDot:2
+68 KILL ^TMP("MCSUB",$JOB,MCSUBFIL)
+69 QUIT
End DoDot:2
+70 IF '$TEST
Begin DoDot:2
+71 SET MCUP=+$GET(^DD(MCSUBFIL,0,"UP"))
+72 SET MCUP=$SELECT(MCUP:MCUP,1:"???")
+73 SET MCFL=+$ORDER(^DD(MCUP,"SB",MCSUBFIL,0))
+74 SET MCFL=$SELECT(MCFL:MCFL,1:"???")
+75 SET MCTEXT="Sub-File # "_MCSUBFIL_" is missing "
+76 SET MCTEXT=MCTEXT_$SELECT(MCUP'=MCFILE:"Sub-",1:"")
+77 SET MCTEXT=MCTEXT_"File/Field # "_MCUP_","_MCFL
+78 SET ^TMP("MCSUB",$JOB,MCSUBFIL)=MCTEXT
+79 QUIT
End DoDot:2
+80 QUIT
End DoDot:1
+81 ;
+82 SET MCSUBFIL=0
+83 FOR
SET MCSUBFIL=$ORDER(^TMP("MCSUB",$JOB,MCSUBFIL))
if MCSUBFIL'>0
QUIT
Begin DoDot:1
+84 DO ERR(^TMP("MCSUB",$JOB,MCSUBFIL))
+85 QUIT
End DoDot:1
+86 KILL ^TMP("MCSUB",$JOB)
+87 QUIT
ERR(X) ;
+1 SET MCERR=MCERR+1
+2 SET ^TMP("MCARVCHK",$JOB,MCERR)=MCNAME_U_MCD0_U_X
+3 QUIT
PAUSE ;
+1 IF $EXTRACT(IOST,1,2)="C-"
Begin DoDot:1
+2 NEW DIR
SET DIR(0)="E"
DO ^DIR
SET MCEXIT=$SELECT(Y'>0:1,1:0)
+3 QUIT
End DoDot:1
+4 IF '$TEST
Begin DoDot:1
+5 SET MCEXIT=0
+6 QUIT
End DoDot:1
+7 QUIT
+1 IF MCEXIT
QUIT
+2 IF ($EXTRACT(IOST,1,2)="C-")!(MCPAGE>1)
WRITE @IOF
+3 WRITE !?25,"MEDICINE VIEW FILE SANITY CHECK",?68,MCTODAY
+4 WRITE !?68,"PAGE: ",MCPAGE
SET MCPAGE=MCPAGE+1
+5 WRITE !,"PRINT VIEW TEMPLATE NAME",?70,"IEN",!?5,"ERROR MESSAGE"
+6 WRITE !,MCUNDL
+7 QUIT
