- MCARDCM1 ;WISC/TJK-MODIFIED DICM1 ROUTINE FOR MEDICINE SCREENS ;3/27/96 12:53
- ;;2.3;Medicine;;09/13/1996
- G @Y
- ;
- P ;POINTERS
- S DICR(DICR,1)=DIC,DIC=U_$P(DS,U,3),Y=DIC(0),D=$P(Y,"L",1)_$P(Y,"L",2),DICR(DICR,2)=$S(MCPCT="B":Y,1:D),DICR(DICR,2.1)=$S($P(DS,U,2)["'":D,1:Y)
- S DIC(0)=$P(D,"N",1)_$P(D,"N",2)
- F Y="S","P","W" I $D(DIC(Y)) S DICR(DICR,Y)=DIC(Y) K DIC(Y)
- AST G P1:$P(DS,U,2)'["*"
- F D=" D ^DIC"," D IX^DIC"," D MIX^DIC1" S Y=$F(DS,D) I Y X $P($E(DS,1,Y-$L(D)-1),U,5,99) S:DS["DIC(0)=" DICR(DICR,2.1)=DIC(0) I $D(DIC("S")) S DICR(DICR,31)=DIC("S")
- P1 S Y="("_DICR(DICR,1) G L1:'$D(DO) K DO I @("$O"_Y_"0))'>0") G L1
- S I="DIC"_DICR,D="X ""I 0"" F "_I_"=0:0 S "_I_"=$O"_Y,MCPCT=""""_MCPCT_""""
- I @("$O"_Y_MCPCT_",0))>0") S D=D_MCPCT_",Y,"_I_")) S:"_I_"="""" "_I_"=-1 Q:"_I_"'>0 I $D"_Y_I_",0))"
- E I DS["DINUM=X" S D="I $D"_Y_"Y,0))"
- E S D=D_I_")) S:"_I_"="""" "_I_"=-1 Q:"_I_"'>0 I +^("_I_",0)=Y"
- I $D(DICR(DICR,31)) S D="X DICR("_DICR_",31) "_D
- I $D(DICR(DICR,"S")) S D=D_" S MCPCTY"_DICR_"=Y,Y="_I_" X DICR("_DICR_",""S"") S Y=MCPCTY"_DICR_" I "
- S DIC("S")=D_" Q",D="B",Y=0 D X^MCARDC
- L1 K DIC("S"),@("DIC"_DICR) I Y'>0,'$D(DICR(DICR,8)) S:$D(DICR(DICR,31)) DIC("S")=DICR(DICR,31) G RETRY
- I DICR(DICR,2)["L",DICR(DICR,2)["E",@("$P("_DIC_"0),U,2)'[""O""") W !?9,"...OK" S MCPCT=1 D YN^MCARDCN W ! I MCPCT-1 X DJCP G NO:MCPCT-2 S DIC("S")="I Y-"_+Y_$S($D(DICR(DICR,31)):" "_DICR(DICR,31),1:""),X=DICR(DICR) W ?5,X G RETRY
- R K DICW,DO,DIC("W"),DIC("S") S DIC=DICR(DICR,1),MCPCT=DICR(DICR,2),DIC(0)=$P(MCPCT,"M",1)_$P(MCPCT,"M",2) F X="S","P","W" S:$D(DICR(DICR,X)) DIC(X)=DICR(DICR,X)
- D DO^MCARDC1 S X=+Y K:X'>0 X Q
- ;
- RETRY D DO^MCARDC1 K DICR(U,+DO(2)) S D="B",DIC(0)=DICR(DICR,2.1) D X^MCARDC K DICR(DICR,6)
- G R
- ;
- NO S Y=-1 G R
- ;
- D ;DATES
- I $S(X?.N:X>49,1:1) S Y=$S($D(^DD(+DO(2),.001)):"N",1:"")_$P($P(DS,"%DT=""",2),"""",1),%DT=$P(Y,"E",1)_$P(Y,"E",2) D ^%DT S X=Y K %DT I X>1 Q:DIC(0)'["E" W " " G DT^DIQ
- K X Q
- ;
- S ;SETS
- S DICR(DICR,1)=1,Y=$P(DS,U,3),DD=$P(";"_Y,";"_X_":",2) I DD]"" W:DIC(0)["E" " (",$P(DD,";",1),")" Q
- SS S DD=$P(Y,";",1),Y=$P(Y,";",2,99) I DD]"" G SS:DD'[(":"_X) W:DIC(0)["E" $P(DD,X,2,9) S X=$P(DD,":",1) Q
- K X S Y=-1 Q
- ;
- V ;VARIABLE POINTER
- I X["?BAD" K X Q
- G ^MCARDCM2
- ;
- LC ;
- Q:DIC(0)["X" S DIC(0)=$P(DIC(0),"L",1)_$P(DIC(0),"L",2)
- F MCPCT=1:1 S Y=$E(X,MCPCT) I Y?.L Q:Y="" S X=$E(X,1,MCPCT-1)_$C($A(Y)-32)_$E(X,MCPCT+1,999)
- G DIC^MCARDCM
- ;
- SOU ;
- S DSOU="01230129022455012623019202",DSOV=X,X=$C($A(X)-(X?1L.E*32)),DIX=$E(DSOU,$A(X)-64) F DIY=2:1 S Y=$E(DSOV,DIY) Q:","[Y I Y?1A S MCPCT=$E(DSOU,$A(Y)-$S(Y?1U:64,1:96)) I MCPCT-DIX,MCPCT-9 S DIX=MCPCT I MCPCT S X=X_MCPCT Q:$L(X)=4
- S X=$E(X_"000",1,4) K DSOU,DSOV
- MCARDCM1 ;WISC/TJK-MODIFIED DICM1 ROUTINE FOR MEDICINE SCREENS ;3/27/96 12:53
- +1 ;;2.3;Medicine;;09/13/1996
- +2 GOTO @Y
- +3 ;
- P ;POINTERS
- +1 SET DICR(DICR,1)=DIC
- SET DIC=U_$PIECE(DS,U,3)
- SET Y=DIC(0)
- SET D=$PIECE(Y,"L",1)_$PIECE(Y,"L",2)
- SET DICR(DICR,2)=$SELECT(MCPCT="B":Y,1:D)
- SET DICR(DICR,2.1)=$SELECT($PIECE(DS,U,2)["'":D,1:Y)
- +2 SET DIC(0)=$PIECE(D,"N",1)_$PIECE(D,"N",2)
- +3 FOR Y="S","P","W"
- IF $DATA(DIC(Y))
- SET DICR(DICR,Y)=DIC(Y)
- KILL DIC(Y)
- AST IF $PIECE(DS,U,2)'["*"
- GOTO P1
- +1 FOR D=" D ^DIC"," D IX^DIC"," D MIX^DIC1"
- SET Y=$FIND(DS,D)
- IF Y
- XECUTE $PIECE($EXTRACT(DS,1,Y-$LENGTH(D)-1),U,5,99)
- IF DS["DIC(0)="
- SET DICR(DICR,2.1)=DIC(0)
- IF $DATA(DIC("S"))
- SET DICR(DICR,31)=DIC("S")
- P1 SET Y="("_DICR(DICR,1)
- IF '$DATA(DO)
- GOTO L1
- KILL DO
- IF @("$O"_Y_"0))'>0")
- GOTO L1
- +1 SET I="DIC"_DICR
- SET D="X ""I 0"" F "_I_"=0:0 S "_I_"=$O"_Y
- SET MCPCT=""""_MCPCT_""""
- +2 IF @("$O"_Y_MCPCT_",0))>0")
- SET D=D_MCPCT_",Y,"_I_")) S:"_I_"="""" "_I_"=-1 Q:"_I_"'>0 I $D"_Y_I_",0))"
- +3 IF '$TEST
- IF DS["DINUM=X"
- SET D="I $D"_Y_"Y,0))"
- +4 IF '$TEST
- SET D=D_I_")) S:"_I_"="""" "_I_"=-1 Q:"_I_"'>0 I +^("_I_",0)=Y"
- +5 IF $DATA(DICR(DICR,31))
- SET D="X DICR("_DICR_",31) "_D
- +6 IF $DATA(DICR(DICR,"S"))
- SET D=D_" S MCPCTY"_DICR_"=Y,Y="_I_" X DICR("_DICR_",""S"") S Y=MCPCTY"_DICR_" I "
- +7 SET DIC("S")=D_" Q"
- SET D="B"
- SET Y=0
- DO X^MCARDC
- L1 KILL DIC("S"),@("DIC"_DICR)
- IF Y'>0
- IF '$DATA(DICR(DICR,8))
- IF $DATA(DICR(DICR,31))
- SET DIC("S")=DICR(DICR,31)
- GOTO RETRY
- +1 IF DICR(DICR,2)["L"
- IF DICR(DICR,2)["E"
- IF @("$P("_DIC_"0),U,2)'[""O""")
- WRITE !?9,"...OK"
- SET MCPCT=1
- DO YN^MCARDCN
- WRITE !
- IF MCPCT-1
- XECUTE DJCP
- IF MCPCT-2
- GOTO NO
- SET DIC("S")="I Y-"_+Y_$SELECT($DATA(DICR(DICR,31)):" "_DICR(DICR,31),1:"")
- SET X=DICR(DICR)
- WRITE ?5,X
- GOTO RETRY
- R KILL DICW,DO,DIC("W"),DIC("S")
- SET DIC=DICR(DICR,1)
- SET MCPCT=DICR(DICR,2)
- SET DIC(0)=$PIECE(MCPCT,"M",1)_$PIECE(MCPCT,"M",2)
- FOR X="S","P","W"
- IF $DATA(DICR(DICR,X))
- SET DIC(X)=DICR(DICR,X)
- +1 DO DO^MCARDC1
- SET X=+Y
- IF X'>0
- KILL X
- QUIT
- +2 ;
- RETRY DO DO^MCARDC1
- KILL DICR(U,+DO(2))
- SET D="B"
- SET DIC(0)=DICR(DICR,2.1)
- DO X^MCARDC
- KILL DICR(DICR,6)
- +1 GOTO R
- +2 ;
- NO SET Y=-1
- GOTO R
- +1 ;
- D ;DATES
- +1 IF $SELECT(X?.N:X>49,1:1)
- SET Y=$SELECT($DATA(^DD(+DO(2),.001)):"N",1:"")_$PIECE($PIECE(DS,"%DT=""",2),"""",1)
- SET %DT=$PIECE(Y,"E",1)_$PIECE(Y,"E",2)
- DO ^%DT
- SET X=Y
- KILL %DT
- IF X>1
- IF DIC(0)'["E"
- QUIT
- WRITE " "
- GOTO DT^DIQ
- +2 KILL X
- QUIT
- +3 ;
- S ;SETS
- +1 SET DICR(DICR,1)=1
- SET Y=$PIECE(DS,U,3)
- SET DD=$PIECE(";"_Y,";"_X_":",2)
- IF DD]""
- IF DIC(0)["E"
- WRITE " (",$PIECE(DD,";",1),")"
- QUIT
- SS SET DD=$PIECE(Y,";",1)
- SET Y=$PIECE(Y,";",2,99)
- IF DD]""
- IF DD'[(":"_X)
- GOTO SS
- IF DIC(0)["E"
- WRITE $PIECE(DD,X,2,9)
- SET X=$PIECE(DD,":",1)
- QUIT
- +1 KILL X
- SET Y=-1
- QUIT
- +2 ;
- V ;VARIABLE POINTER
- +1 IF X["?BAD"
- KILL X
- QUIT
- +2 GOTO ^MCARDCM2
- +3 ;
- LC ;
- +1 IF DIC(0)["X"
- QUIT
- SET DIC(0)=$PIECE(DIC(0),"L",1)_$PIECE(DIC(0),"L",2)
- +2 FOR MCPCT=1:1
- SET Y=$EXTRACT(X,MCPCT)
- IF Y?.L
- IF Y=""
- QUIT
- SET X=$EXTRACT(X,1,MCPCT-1)_$CHAR($ASCII(Y)-32)_$EXTRACT(X,MCPCT+1,999)
- +3 GOTO DIC^MCARDCM
- +4 ;
- SOU ;
- +1 SET DSOU="01230129022455012623019202"
- SET DSOV=X
- SET X=$CHAR($ASCII(X)-(X?1L.E*32))
- SET DIX=$EXTRACT(DSOU,$ASCII(X)-64)
- FOR DIY=2:1
- SET Y=$EXTRACT(DSOV,DIY)
- IF ","[Y
- QUIT
- IF Y?1A
- SET MCPCT=$EXTRACT(DSOU,$ASCII(Y)-$SELECT(Y?1U:64,1:96))
- IF MCPCT-DIX
- IF MCPCT-9
- SET DIX=MCPCT
- IF MCPCT
- SET X=X_MCPCT
- IF $LENGTH(X)=4
- QUIT
- +2 SET X=$EXTRACT(X_"000",1,4)
- KILL DSOU,DSOV
