- 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
