- MCARDCM2 ;WISC/TJK-MODIFIED DICM2 ROUTINE FOR MEDICINE SCREENS ;8/22/96 15:21
- ;;2.3;Medicine;;09/13/1996
- ;VAR PNTR
- S DIVDO=+DO(2),DIVDS=DS,DIVDIC=DIC F MCPCT="DR","S","A","V" I $D(DIC(MCPCT)) S @("DIV"_MCPCT)=DIC(MCPCT)
- K DIC("W"),DIC("S"),DIC("DR"),DO,DUOUT S DIEX=X G ALL:X'["." I $P(X,".",2)="" S Y=-1 G Q
- V S DIVP=$P(DIEX,".",1),X=$P(DIEX,".",2) I DIVP]"",$D(^DD(DIVDO,.01,"V","P",DIVP)) S (DIVP,DIVPDIC)=+$O(^(DIVP,0)),DIVPDIC=$S($D(^DD(DIVDO,.01,"V",DIVP,0)):^(0),1:"") G Q:'DIVPDIC D DIC G Q
- S X="",DIVP=$P(DIEX,".",1) F MCPCT=0:0 S X=$O(^DD(DIVDO,.01,"V","M",X)) Q:X="" I $P(X,DIVP,1)="" S (DIVP,DIVPDIC)=+$O(^(X,0)),DIVPDIC=$S($D(^DD(DIVDO,.01,"V",DIVP,0)):^(0),1:""),X=$P(DIEX,".",2) G Q:'DIVPDIC D DIC G Q:Y>0 S X=DIEX
- F DIVP=0:0 S DIVP=$O(^DD(DIVDO,.01,"V",DIVP)) S:DIVP="" DIVP=-1 Q:DIVP'>0 I $D(^(DIVP,0)) S DIVPDIC=^(0) I $D(^DIC(+DIVPDIC,0)) S MCPCT=$P(^(0),U,1) I $P(MCPCT,$P(DIEX,".",1),1)="" S X=$P(DIEX,".",2) D DIC G Q:Y>0 S X=DIEX
- K X G Q
- ALL F DIVP1=0:0 S DIVP1=$O(^DD(DIVDO,.01,"V","O",DIVP1)) S:DIVP1="" DIVP1=-1 Q:DIVP1'>0 S DIVP=$O(^(DIVP1,0)) S:DIVP="" DIVP=-1 I $D(^DD(DIVDO,.01,"V",DIVP,0)) S DIVPDIC=^(0) D DIC G Q:Y>0!(MCPCT<0)!$D(DUOUT) S X=DIEX
- G Q:DICR>1!$D(DICR(DICR,"V")) S DICR(DICR,"V")=1 K DIVP G ALL
- ;
- DIC ;
- 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
- S DIC=^DIC(+DIVPDIC,0,"GL"),MCPCT="DIC"_DICR
- IF DIC(0)'["L"!'$D(DICR(DICR,"V")) D
- . S DIC("S")="X ""I 0"" F "_MCPCT_"=0:0 S "_MCPCT_"=$O("_DIVDIC_"""B"",(+Y_"";"_$E(DIC,2,99)_"""),"_MCPCT_")) S:"_MCPCT_"="""" "_MCPCT_"=-1 Q:"_MCPCT_"'>0 I $D("_DIVDIC_MCPCT_",0))"
- . S DIC("S")=DIC("S")_$S($D(DIVS):"S MCPCTYV=Y,Y="_MCPCT_" X DIVS S Y=MCPCTYV I ",1:"")_" Q"
- . Q
- ;END IF
- ;
- 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,.01,"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,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(DIVV) S DIC("V")=DIVV
- Q
- ;
- Q I '$D(DUOUT),Y<0,DICR<2,'$D(DICR(DICR,"V")) S DICR(DICR,"V")=1 K DIVP G V
- K:Y<0 X S DS=DIVDS,DICR(DICR,"V")=1 S:$D(DIVDR) DIC("DR")=DIVDR S:$D(DIVA) DIC("A")=DIVA S:$D(DIVS) DIC("S")=DIVS
- QQ K:Y DICR(DICR,6) K DUOUT,DIVV,DIVP,DIVDIC,DO,DIVDO,DIVDS,DIVS,DIVPDIC,DIEX,DIVP1,DIVDR,DIVA Q
- ;
- NAME ;DETERMINE EXTERNAL FORM FROM INTERNAL FOR VP
- S DINAME=DIY Q:'DIY S MCPCT=$P(DIY,";",2),DINAME="^"_MCPCT_+DIY_",0)",DINAME=$S($D(@DINAME)#2:$P(^(0),U,1),1:DIY),MCPCT=$S($D(@("^"_MCPCT_"0)")):$P(^(0),U,2),1:"") Q:MCPCT=""
- I MCPCT["P"!(MCPCT["S")!(MCPCT["D") S DJC=MCPCT,MCPCTYYY=DIY,MCPCTYY=Y,Y=DINAME D Y K DJC S DINAME=Y,DIY=MCPCTYYY,Y=MCPCTYY,C="," K MCPCTYY,MCPCTYYY
- Q
- Y S C=$P(^DD(+DJC,.01,0),U,2) I C["O",$D(^(2)) X ^(2) Q
- S I C["S" S C=";"_$P(^DD(+DJC,.01,0),U,3),MCPCT=$F(C,";"_Y_":") S:MCPCT Y=$P($E(C,MCPCT,999),";",1) Q
- I C["P",$D(@("^"_$P(^DD(+DJC,.01,0),U,3)_"0)")) S (C,DJC)=$P(^(0),U,2) I $D(^(+Y,0)) S Y=$P(^(0),U,1) I $D(^DD(+C,.01,0)) S C=$P(^(0),U,2) G S
- I C["V",+Y,$D(@("^"_$P(Y,";",2)_"0)")) S C=$P(^(0),U,2) I $D(^(+Y,0)) S Y=$P(^(0),U,1) I $D(^DD(+C,.01,0)) S C=$P(^(0),U,2) G S
- Q:C'["D" Q:'Y
- D S MCPCT=$E(Y,4,5)*3,Y=$E("JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC",MCPCT-2,MCPCT)_" "_$S($E(Y,6,7):$J(+$E(Y,6,7),2)_", ",1:"")_($E(Y,1,3)+1700)_$S(Y[".":" "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12),1:"") Q
- MCARDCM2 ;WISC/TJK-MODIFIED DICM2 ROUTINE FOR MEDICINE SCREENS ;8/22/96 15:21
- +1 ;;2.3;Medicine;;09/13/1996
- +2 ;VAR PNTR
- +3 SET DIVDO=+DO(2)
- SET DIVDS=DS
- SET DIVDIC=DIC
- FOR MCPCT="DR","S","A","V"
- IF $DATA(DIC(MCPCT))
- SET @("DIV"_MCPCT)=DIC(MCPCT)
- +4 KILL DIC("W"),DIC("S"),DIC("DR"),DO,DUOUT
- SET DIEX=X
- IF X'["."
- GOTO ALL
- IF $PIECE(X,".",2)=""
- SET Y=-1
- GOTO Q
- V SET DIVP=$PIECE(DIEX,".",1)
- SET X=$PIECE(DIEX,".",2)
- IF DIVP]""
- IF $DATA(^DD(DIVDO,.01,"V","P",DIVP))
- SET (DIVP,DIVPDIC)=+$ORDER(^(DIVP,0))
- SET DIVPDIC=$SELECT($DATA(^DD(DIVDO,.01,"V",DIVP,0)):^(0),1:"")
- IF 'DIVPDIC
- GOTO Q
- DO DIC
- GOTO Q
- +1 SET X=""
- SET DIVP=$PIECE(DIEX,".",1)
- FOR MCPCT=0:0
- SET X=$ORDER(^DD(DIVDO,.01,"V","M",X))
- IF X=""
- QUIT
- IF $PIECE(X,DIVP,1)=""
- SET (DIVP,DIVPDIC)=+$ORDER(^(X,0))
- SET DIVPDIC=$SELECT($DATA(^DD(DIVDO,.01,"V",DIVP,0)):^(0),1:"")
- SET X=$PIECE(DIEX,".",2)
- IF 'DIVPDIC
- GOTO Q
- DO DIC
- IF Y>0
- GOTO Q
- SET X=DIEX
- +2 FOR DIVP=0:0
- SET DIVP=$ORDER(^DD(DIVDO,.01,"V",DIVP))
- IF DIVP=""
- SET DIVP=-1
- IF DIVP'>0
- QUIT
- IF $DATA(^(DIVP,0))
- SET DIVPDIC=^(0)
- IF $DATA(^DIC(+DIVPDIC,0))
- SET MCPCT=$PIECE(^(0),U,1)
- IF $PIECE(MCPCT,$PIECE(DIEX,".",1),1)=""
- SET X=$PIECE(DIEX,".",2)
- DO DIC
- IF Y>0
- GOTO Q
- SET X=DIEX
- +3 KILL X
- GOTO Q
- ALL FOR DIVP1=0:0
- SET DIVP1=$ORDER(^DD(DIVDO,.01,"V","O",DIVP1))
- IF DIVP1=""
- SET DIVP1=-1
- IF DIVP1'>0
- QUIT
- SET DIVP=$ORDER(^(DIVP1,0))
- IF DIVP=""
- SET DIVP=-1
- IF $DATA(^DD(DIVDO,.01,"V",DIVP,0))
- SET DIVPDIC=^(0)
- DO DIC
- IF Y>0!(MCPCT<0)!$DATA(DUOUT)
- GOTO Q
- SET X=DIEX
- +1 IF DICR>1!$DATA(DICR(DICR,"V"))
- GOTO Q
- SET DICR(DICR,"V")=1
- KILL DIVP
- GOTO ALL
- +2 ;
- DIC ;
- +1 IF $DATA(DIVP(+DIVPDIC))
- QUIT
- IF $DATA(DIC("V"))
- SET Y=DIVP
- SET Y(0)=DIVPDIC
- XECUTE DIC("V")
- IF '$TEST
- KILL Y
- SET Y=-1
- GOTO DQ
- +2 IF '$DATA(^DIC(+DIVPDIC,0,"GL"))
- SET Y=-1
- GOTO DQ
- +3 SET DIC=^DIC(+DIVPDIC,0,"GL")
- SET MCPCT="DIC"_DICR
- +4 IF DIC(0)'["L"!'$DATA(DICR(DICR,"V"))
- Begin DoDot:1
- +5 SET DIC("S")="X ""I 0"" F "_MCPCT_"=0:0 S "_MCPCT_"=$O("_DIVDIC_"""B"",(+Y_"";"_$EXTRACT(DIC,2,99)_"""),"_MCPCT_")) S:"_MCPCT_"="""" "_MCPCT_"=-1 Q:"_MCPCT_"'>0 I $D("_DIVDIC_MCPCT_",0))"
- +6 SET DIC("S")=DIC("S")_$SELECT($DATA(DIVS):"S MCPCTYV=Y,Y="_MCPCT_" X DIVS S Y=MCPCTYV I ",1:"")_" Q"
- +7 QUIT
- End DoDot:1
- +8 ;END IF
- +9 ;
- +10 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"
- +11 IF $DATA(DICR(DICR,"V"))
- IF $PIECE(DIVPDIC,U,5)="y"
- IF $DATA(^DD(DIVDO,.01,"V",DIVP,1))
- IF ^(1)]""
- SET MCPCT=$SELECT($DATA(DIC("S")):DIC("S"),1:"")
- XECUTE ^(1)
- SET DIC("S")=DIC("S")_" "_MCPCT
- +12 IF DIC(0)["E"
- IF $DATA(DIVP1)
- IF $DATA(DICR(DICR,"V"))
- WRITE !!?5,"Searching for a "_$PIECE(DIVPDIC,U,2)
- +13 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
- +14 DO DO^MCARDC1
- DO X^MCARDC
- IF $DATA(DUOUT)
- GOTO DQ
- SET X=+Y_";"_$EXTRACT(DIC,2,99)
- SET MCPCT=1
- IF Y<0
- KILL X
- IF '$DATA(DICR(DICR,"V"))
- KILL DICR("^",+DIVPDIC)
- SET DIVP(+DIVPDIC)=0
- +15 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(DIVV)
- SET DIC("V")=DIVV
- +1 QUIT
- +2 ;
- Q IF '$DATA(DUOUT)
- IF Y<0
- IF DICR<2
- IF '$DATA(DICR(DICR,"V"))
- SET DICR(DICR,"V")=1
- KILL DIVP
- GOTO V
- +1 IF Y<0
- KILL X
- SET DS=DIVDS
- SET DICR(DICR,"V")=1
- IF $DATA(DIVDR)
- SET DIC("DR")=DIVDR
- IF $DATA(DIVA)
- SET DIC("A")=DIVA
- IF $DATA(DIVS)
- SET DIC("S")=DIVS
- QQ IF Y
- KILL DICR(DICR,6)
- KILL DUOUT,DIVV,DIVP,DIVDIC,DO,DIVDO,DIVDS,DIVS,DIVPDIC,DIEX,DIVP1,DIVDR,DIVA
- QUIT
- +1 ;
- NAME ;DETERMINE EXTERNAL FORM FROM INTERNAL FOR VP
- +1 SET DINAME=DIY
- IF 'DIY
- QUIT
- SET MCPCT=$PIECE(DIY,";",2)
- SET DINAME="^"_MCPCT_+DIY_",0)"
- SET DINAME=$SELECT($DATA(@DINAME)#2:$PIECE(^(0),U,1),1:DIY)
- SET MCPCT=$SELECT($DATA(@("^"_MCPCT_"0)")):$PIECE(^(0),U,2),1:"")
- IF MCPCT=""
- QUIT
- +2 IF MCPCT["P"!(MCPCT["S")!(MCPCT["D")
- SET DJC=MCPCT
- SET MCPCTYYY=DIY
- SET MCPCTYY=Y
- SET Y=DINAME
- DO Y
- KILL DJC
- SET DINAME=Y
- SET DIY=MCPCTYYY
- SET Y=MCPCTYY
- SET C=","
- KILL MCPCTYY,MCPCTYYY
- +3 QUIT
- Y SET C=$PIECE(^DD(+DJC,.01,0),U,2)
- IF C["O"
- IF $DATA(^(2))
- XECUTE ^(2)
- QUIT
- S IF C["S"
- SET C=";"_$PIECE(^DD(+DJC,.01,0),U,3)
- SET MCPCT=$FIND(C,";"_Y_":")
- IF MCPCT
- SET Y=$PIECE($EXTRACT(C,MCPCT,999),";",1)
- QUIT
- +1 IF C["P"
- IF $DATA(@("^"_$PIECE(^DD(+DJC,.01,0),U,3)_"0)"))
- SET (C,DJC)=$PIECE(^(0),U,2)
- IF $DATA(^(+Y,0))
- SET Y=$PIECE(^(0),U,1)
- IF $DATA(^DD(+C,.01,0))
- SET C=$PIECE(^(0),U,2)
- GOTO S
- +2 IF C["V"
- IF +Y
- IF $DATA(@("^"_$PIECE(Y,";",2)_"0)"))
- SET C=$PIECE(^(0),U,2)
- IF $DATA(^(+Y,0))
- SET Y=$PIECE(^(0),U,1)
- IF $DATA(^DD(+C,.01,0))
- SET C=$PIECE(^(0),U,2)
- GOTO S
- +3 IF C'["D"
- QUIT
- IF 'Y
- QUIT
- D SET MCPCT=$EXTRACT(Y,4,5)*3
- SET Y=$EXTRACT("JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC",MCPCT-2,MCPCT)_" "_$SELECT($EXTRACT(Y,6,7):$JUSTIFY(+$EXTRACT(Y,6,7),2)_", ",1:"")_($EXTRACT(Y,1,3)+1700)_$SELECT(Y[".":" "_$EXTRACT(Y_0,9,10)_":"_$EXTRACT(Y_"000",11,12),1:"")
- QUIT
