MCARDCM3.m

MCARDCM3 ;WISC/TJK-MODIFIED DICM3 ROUTINE FOR MEDICINE SCREEN ;5/2/96  12:57

 ;;2.3;Medicine;;09/13/1996

 ;;17.7;VA FileMan; 6/9/89

DIC ;

 N DIVY

 Q:$D(DIVP(+DIVPDIC))

 I $D(DIC("V")) S Y=DIVP,Y(0)=DIVPDIC X DIC("V") I '$T K Y S Y=-1 G DQ

 I '$D(^DIC(+DIVPDIC,0,"GL")) S Y=-1 G DQ

 ; Naked Reference in DIC+5 is refs in line tag: DIC+3

 S DIC=^("GL"),MCPCT="DIC"_DICR

 ;FOLLOWING 2 LINES MODIFIED FOR VERIFICATION PER T. ASH 2/20/92 MLH

 I DIC(0)'["L"!'$D(DICR(DICR,"V")) D

 .  S DIC("S")="X ""I 0"" F "_MCPCT_"=0:0 S "_MCPCT_"=$O("_DIVDIC_""""_D_""""_",(+Y_"";"_$E(DIC,2,99)_"""),"_MCPCT_")) S:"_MCPCT_"="""" "

 .  S DIC("S")=DIC("S")_MCPCT_"=-1 Q:"_MCPCT_"'>0  I $D("_DIVDIC_MCPCT_",0))"_$S($D(DIV("S")):" S MCPCTYV=Y,Y="_MCPCT_" X DIV(""S"") S Y=MCPCTYV I ",1:"")_" Q"

 S MCPCT=DIC(0),DIC(0)="DM"_$E("E",MCPCT["E")_$E("O",MCPCT["O") I $P(DIVPDIC,U,6)="y",$D(DICR(DICR,"V")),MCPCT["L" S DIC(0)=DIC(0)_"L"

 I $D(DICR(DICR,"V")),$P(DIVPDIC,U,5)="y",$D(^DD(DIVDO,DIVY,"V",DIVP,1)),^(1)]"" S MCPCT=$S($D(DIC("S")):DIC("S"),1:"") X ^(1) S DIC("S")=DIC("S")_" "_MCPCT

 I DIC(0)["E",$D(DIVP1),$D(DICR(DICR,"V")) W !!?5,"Searching for a "_$P(DIVPDIC,U,2)

 I X?."?" S DZ=X_$E("?",'$D(DICR(DICR,"V"))) D DQ^MCARDCQ S X=$S($D(DZ):DZ,1:"?"),Y=-1 G DQ

 D DO^MCARDC1

 S D="B" D X^MCARDC G DQ:$D(DUOUT) S X=+Y_";"_$E(DIC,2,99),MCPCT=1 K:Y<0 X

 I '$D(DICR(DICR,"V")) K DICR("^",+DIVPDIC) S DIVP(+DIVPDIC)=0

 I Y>0,$D(DIVP1),DIC(0)["E",'$P(Y,U,3),$P(^DIC(+DIVPDIC,0),U,2)'["O" W !?9,"...OK" D YN^MCARDCN S:MCPCT=2!(MCPCT<0) Y=-1

DQ K DIC,DO S DIC=DIVDIC,D=$S($D(DICR(DICR,4)):DICR(DICR,4),1:"B"),DIC(0)=DICR(DICR,0) I $D(DIV("V")) S DIC("V")=DIV("V")

 Q

MCARDCM3  ;WISC/TJK-MODIFIED DICM3 ROUTINE FOR MEDICINE SCREEN ;5/2/96  12:57

 +1       ;;2.3;Medicine;;09/13/1996

 +2       ;;17.7;VA FileMan; 6/9/89

DIC       ;

 +1        NEW DIVY

 +2        IF $DATA(DIVP(+DIVPDIC))

               QUIT 

 +3        IF $DATA(DIC("V"))

               SET Y=DIVP

               SET Y(0)=DIVPDIC

               XECUTE DIC("V")

               IF '$TEST

                   KILL Y

                   SET Y=-1

                   GOTO DQ

 +4        IF '$DATA(^DIC(+DIVPDIC,0,"GL"))

               SET Y=-1

               GOTO DQ

 +5       ; Naked Reference in DIC+5 is refs in line tag: DIC+3

 +6        SET DIC=^("GL")

           SET MCPCT="DIC"_DICR

 +7       ;FOLLOWING 2 LINES MODIFIED FOR VERIFICATION PER T. ASH 2/20/92 MLH

 +8        IF DIC(0)'["L"!'$DATA(DICR(DICR,"V"))

               Begin DoDot:1

 +9                SET DIC("S")="X ""I 0"" F "_MCPCT_"=0:0 S "_MCPCT_"=$O("_DIVDIC_""""_D_""""_",(+Y_"";"_$EXTRACT(DIC,2,99)_"""),"_MCPCT_")) S:"_MCPCT_"="""" "

 +10               SET DIC("S")=DIC("S")_MCPCT_"=-1 Q:"_MCPCT_"'>0  I $D("_DIVDIC_MCPCT_",0))"_$SELECT($DATA(DIV("S")):" S MCPCTYV=Y,Y="_MCPCT_" X DIV(""S"") S Y=MCPCTYV I ",1:"")_" Q"

               End DoDot:1

 +11       SET MCPCT=DIC(0)

           SET DIC(0)="DM"_$EXTRACT("E",MCPCT["E")_$EXTRACT("O",MCPCT["O")

           IF $PIECE(DIVPDIC,U,6)="y"

               IF $DATA(DICR(DICR,"V"))

                   IF MCPCT["L"

                       SET DIC(0)=DIC(0)_"L"

 +12       IF $DATA(DICR(DICR,"V"))

               IF $PIECE(DIVPDIC,U,5)="y"

                   IF $DATA(^DD(DIVDO,DIVY,"V",DIVP,1))

                       IF ^(1)]""

                           SET MCPCT=$SELECT($DATA(DIC("S")):DIC("S"),1:"")

                           XECUTE ^(1)

                           SET DIC("S")=DIC("S")_" "_MCPCT

 +13       IF DIC(0)["E"

               IF $DATA(DIVP1)

                   IF $DATA(DICR(DICR,"V"))

                       WRITE !!?5,"Searching for a "_$PIECE(DIVPDIC,U,2)

 +14       IF X?."?"

               SET DZ=X_$EXTRACT("?",'$DATA(DICR(DICR,"V")))

               DO DQ^MCARDCQ

               SET X=$SELECT($DATA(DZ):DZ,1:"?")

               SET Y=-1

               GOTO DQ

 +15       DO DO^MCARDC1

 +16       SET D="B"

           DO X^MCARDC

           IF $DATA(DUOUT)

               GOTO DQ

           SET X=+Y_";"_$EXTRACT(DIC,2,99)

           SET MCPCT=1

           IF Y<0

               KILL X

 +17       IF '$DATA(DICR(DICR,"V"))

               KILL DICR("^",+DIVPDIC)

               SET DIVP(+DIVPDIC)=0

 +18       IF Y>0

               IF $DATA(DIVP1)

                   IF DIC(0)["E"

                       IF '$PIECE(Y,U,3)

                           IF $PIECE(^DIC(+DIVPDIC,0),U,2)'["O"

                               WRITE !?9,"...OK"

                               DO YN^MCARDCN

                               IF MCPCT=2!(MCPCT<0)

                                   SET Y=-1

DQ         KILL DIC,DO

           SET DIC=DIVDIC

           SET D=$SELECT($DATA(DICR(DICR,4)):DICR(DICR,4),1:"B")

           SET DIC(0)=DICR(DICR,0)

           IF $DATA(DIV("V"))

               SET DIC("V")=DIV("V")

 +1        QUIT