- MCARDCN ;WISC/TJK-MODIFIED DICN ROUTINE FOR MEDICINE SCREENS ;7/24/96 07:35
- ;;2.3;Medicine;;09/13/1996
- S DO(1)=1
- I $S($D(DLAYGO):DO(2)\1-(DLAYGO\1),1:1),DUZ(0)'="@",$D(^DIC(+DO(2),0,"LAYGO")) F MCPCT=1:1 I DUZ(0)[$E(^("LAYGO"),MCPCT) G B:MCPCT>$L(^("LAYGO")) Q
- I $D(DD) S X=DD D N^MCARDCN1 G I:$D(X),B
- D DS S DIX=X I X?.NP,X,DIC(0)["E",'$D(DICR),DS'["DINUM",$P(DS,U,2)'["N",DIC(0)["N"!$D(^DD(+DO(2),.001,0)) D N^MCARDCN1 I $D(X) S DD=X G I
- S X=DIX D VAL G I:$D(X)
- S X=DIX
- B K Y(0) G BAD^MCARDC1
- ;
- 1 I '$D(DIC("S")) W " (THE ",Y,$S(Y#10=1&(Y#100-11):"ST",Y#10=2&(Y#100-12):"ND",Y#10=3&(Y#100-13):"RD",1:"TH"),$S('$D(^DD(+DO(2),0,"UP")):"",1:" FOR THIS "_$O(^DD(^("UP"),0,"NM",0))),")"
- YN ;
- W "? ",$P("YES// ^NO// ",U,MCPCT)
- RX R MCPCTY:DTIME E S DTOUT=1,MCPCTY=U W *7
- S:MCPCTY]""!'MCPCT MCPCT=$A(MCPCTY),MCPCT=$S(MCPCT=89:1,MCPCT=121:1,MCPCT=78:2,MCPCT=110:2,MCPCT=94:-1,1:0)
- I 'MCPCT,MCPCTY'?."?" W *7,"??",!?4,"ANSWER 'YES' OR 'NO': " G RX
- W:$X>73 ! W $P(" (YES)^ (NO)",U,MCPCT) Q
- ;
- DS S DS=^DD(+DO(2),.01,0) Q
- ;
- VAL I X'?.ANP!($A(X)=45) K X Q
- I $P(DS,U,2)["*" S:DS["DINUM" DINUM=X Q
- S MCPCT=$F(DS,"%DT=""E"),DS=$E(DS,1,MCPCT-2)_$E(DS,MCPCT,999) X $P(DS,U,5,99) Q
- ;
- ;; ***ORIGINAL*** ;; I I DIC(0)["E",DO(2)'["A" S DJC=+DO(2),Y=X D Y^MCARDCM2 K DJC X:$Y>20 DJCP W *7,!?3,"ARE YOU ADDING " W:'$D(DD) "'"_Y_"' AS " S MCPCT=$P(DO,U,1) W !?7 W "A NEW "_MCPCT S MCPCT=0,Y=$P(DO,U,4)+1 D 1 G B:MCPCT-1
- I I DIC(0)["E",DO(2)'["A" S DJC=+DO(2),Y=X D Y^MCARDCM2 K DJC X DJCP W *7,!?3,"ARE YOU ADDING " W:'$D(DD) "'"_Y_"' AS " S MCPCT=$P(DO,U,1) W !?7 W "A NEW "_MCPCT S MCPCT=0,Y=$P(DO,U,4)+1 D 1 G B:MCPCT-1
- G FILE:'$D(DD)
- R D DS W !?3,$P(DS,U,1),": " R X:DTIME S:'$T X=U
- G B:X[U,R:X="" D VAL I '$D(X) W *7,"??" W:$D(^DD(+DO(2),.01,3)) !,^(3) G R
- FILE D:'$D(DO) DO^MCARDC1 F DIX=0:0 S DIX=$O(^DD(+DO(2),.01,"LAYGO",DIX)) Q:DIX'>0 I $D(^(DIX,0)) X ^(0) I '$T S Y=-1 G A^MCARDC:$D(DO(1)),Q^MCARDC
- S DIX=X
- F1 S X=$P(DO,U,3) D INCR S X=X\DIY*DIY+DIY
- I $D(DINUM) S X=DINUM D INCR
- F2 I $D(@(DIC_"X)")) S X=X\DIY*DIY+DIY G B:$D(DINUM),F2
- S Y=$P(DO,"^",2) I $D(DD) S X=DD
- E I 'Y,DUZ(0)'="@" G LOCK
- I DIC(0)["E",$D(^DD(+Y,.001,0)) G NUM^MCARDCN1
- LOCK L @(DIC_"X):1") I $D(@(DIC_"X)"))!'$T L W *7 G F1
- ; Nake Reference in LOCK+3 is refs in Line tag LOCK
- ; DIC is set to ^MCAR(xxx, where xxx is a file number.
- S ^(X,0)=DIX,DD=0 L K D S:$D(DA)#2 D=DA S DA=X,X=DIX
- I $D(@(DIC_"0)")) S ^(0)=$P(^(0),"^",1,2)_"^"_DA_"^"_($P(^(0),"^",4)+1)
- IX S DS=X,DD=$O(^DD(+DO(2),.01,1,DD)) S:DD="" DD=-1 I DD>0 G RIX^MCARDCN1:^(DD,0)["TRIGGER"!(^(0)["BULL") X ^(1) S X=DS G IX
- I DIC(0)["E"&($O(^DD(+DO(2),0,"ID",0))>0)!$D(DIC("DR")) G ^MCARDCN1
- D ;
- S Y=DA_"^"_X_"^"_1 S:$D(D)#2 DA=D G R^MCARDC
- ;
- INCR S DIY=1 I $P(DO,U,2)>1 F MCPCT=1:1:$L($P(X,".",2)) S DIY=DIY/10
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCARDCN 2821 printed Apr 23, 2025@18:27:06 Page 2
- MCARDCN ;WISC/TJK-MODIFIED DICN ROUTINE FOR MEDICINE SCREENS ;7/24/96 07:35
- +1 ;;2.3;Medicine;;09/13/1996
- +2 SET DO(1)=1
- +3 IF $SELECT($DATA(DLAYGO):DO(2)\1-(DLAYGO\1),1:1)
- IF DUZ(0)'="@"
- IF $DATA(^DIC(+DO(2),0,"LAYGO"))
- FOR MCPCT=1:1
- IF DUZ(0)[$EXTRACT(^("LAYGO"),MCPCT)
- if MCPCT>$LENGTH(^("LAYGO"))
- GOTO B
- QUIT
- +4 IF $DATA(DD)
- SET X=DD
- DO N^MCARDCN1
- if $DATA(X)
- GOTO I
- GOTO B
- +5 DO DS
- SET DIX=X
- IF X?.NP
- IF X
- IF DIC(0)["E"
- IF '$DATA(DICR)
- IF DS'["DINUM"
- IF $PIECE(DS,U,2)'["N"
- IF DIC(0)["N"!$DATA(^DD(+DO(2),.001,0))
- DO N^MCARDCN1
- IF $DATA(X)
- SET DD=X
- GOTO I
- +6 SET X=DIX
- DO VAL
- if $DATA(X)
- GOTO I
- +7 SET X=DIX
- B KILL Y(0)
- GOTO BAD^MCARDC1
- +1 ;
- 1 IF '$DATA(DIC("S"))
- WRITE " (THE ",Y,$SELECT(Y#10=1&(Y#100-11):"ST",Y#10=2&(Y#100-12):"ND",Y#10=3&(Y#100-13):"RD",1:"TH"),$SELECT('$DATA(^DD(+DO(2),0,"UP")):"",1:" FOR THIS "_$ORDER(^DD(^("UP"),0,"NM",0))),")"
- YN ;
- +1 WRITE "? ",$PIECE("YES// ^NO// ",U,MCPCT)
- RX READ MCPCTY:DTIME
- IF '$TEST
- SET DTOUT=1
- SET MCPCTY=U
- WRITE *7
- +1 if MCPCTY]""!'MCPCT
- SET MCPCT=$ASCII(MCPCTY)
- SET MCPCT=$SELECT(MCPCT=89:1,MCPCT=121:1,MCPCT=78:2,MCPCT=110:2,MCPCT=94:-1,1:0)
- +2 IF 'MCPCT
- IF MCPCTY'?."?"
- WRITE *7,"??",!?4,"ANSWER 'YES' OR 'NO': "
- GOTO RX
- +3 if $X>73
- WRITE !
- WRITE $PIECE(" (YES)^ (NO)",U,MCPCT)
- QUIT
- +4 ;
- DS SET DS=^DD(+DO(2),.01,0)
- QUIT
- +1 ;
- VAL IF X'?.ANP!($ASCII(X)=45)
- KILL X
- QUIT
- +1 IF $PIECE(DS,U,2)["*"
- if DS["DINUM"
- SET DINUM=X
- QUIT
- +2 SET MCPCT=$FIND(DS,"%DT=""E")
- SET DS=$EXTRACT(DS,1,MCPCT-2)_$EXTRACT(DS,MCPCT,999)
- XECUTE $PIECE(DS,U,5,99)
- QUIT
- +3 ;
- +4 ;; ***ORIGINAL*** ;; I I DIC(0)["E",DO(2)'["A" S DJC=+DO(2),Y=X D Y^MCARDCM2 K DJC X:$Y>20 DJCP W *7,!?3,"ARE YOU ADDING " W:'$D(DD) "'"_Y_"' AS " S MCPCT=$P(DO,U,1) W !?7 W "A NEW "_MCPCT S MCPCT=0,Y=$P(DO,U,4)+1 D 1 G B:MCPCT-1
- I IF DIC(0)["E"
- IF DO(2)'["A"
- SET DJC=+DO(2)
- SET Y=X
- DO Y^MCARDCM2
- KILL DJC
- XECUTE DJCP
- WRITE *7,!?3,"ARE YOU ADDING "
- if '$DATA(DD)
- WRITE "'"_Y_"' AS "
- SET MCPCT=$PIECE(DO,U,1)
- WRITE !?7
- WRITE "A NEW "_MCPCT
- SET MCPCT=0
- SET Y=$PIECE(DO,U,4)+1
- DO 1
- if MCPCT-1
- GOTO B
- +1 if '$DATA(DD)
- GOTO FILE
- R DO DS
- WRITE !?3,$PIECE(DS,U,1),": "
- READ X:DTIME
- if '$TEST
- SET X=U
- +1 if X[U
- GOTO B
- if X=""
- GOTO R
- DO VAL
- IF '$DATA(X)
- WRITE *7,"??"
- if $DATA(^DD(+DO(2),.01,3))
- WRITE !,^(3)
- GOTO R
- FILE if '$DATA(DO)
- DO DO^MCARDC1
- FOR DIX=0:0
- SET DIX=$ORDER(^DD(+DO(2),.01,"LAYGO",DIX))
- if DIX'>0
- QUIT
- IF $DATA(^(DIX,0))
- XECUTE ^(0)
- IF '$TEST
- SET Y=-1
- if $DATA(DO(1))
- GOTO A^MCARDC
- GOTO Q^MCARDC
- +1 SET DIX=X
- F1 SET X=$PIECE(DO,U,3)
- DO INCR
- SET X=X\DIY*DIY+DIY
- +1 IF $DATA(DINUM)
- SET X=DINUM
- DO INCR
- F2 IF $DATA(@(DIC_"X)"))
- SET X=X\DIY*DIY+DIY
- if $DATA(DINUM)
- GOTO B
- GOTO F2
- +1 SET Y=$PIECE(DO,"^",2)
- IF $DATA(DD)
- SET X=DD
- +2 IF '$TEST
- IF 'Y
- IF DUZ(0)'="@"
- GOTO LOCK
- +3 IF DIC(0)["E"
- IF $DATA(^DD(+Y,.001,0))
- GOTO NUM^MCARDCN1
- LOCK LOCK @(DIC_"X):1")
- IF $DATA(@(DIC_"X)"))!'$TEST
- LOCK
- WRITE *7
- GOTO F1
- +1 ; Nake Reference in LOCK+3 is refs in Line tag LOCK
- +2 ; DIC is set to ^MCAR(xxx, where xxx is a file number.
- +3 SET ^(X,0)=DIX
- SET DD=0
- LOCK
- KILL D
- if $DATA(DA)#2
- SET D=DA
- SET DA=X
- SET X=DIX
- +4 IF $DATA(@(DIC_"0)"))
- SET ^(0)=$PIECE(^(0),"^",1,2)_"^"_DA_"^"_($PIECE(^(0),"^",4)+1)
- IX SET DS=X
- SET DD=$ORDER(^DD(+DO(2),.01,1,DD))
- if DD=""
- SET DD=-1
- IF DD>0
- if ^(DD,0)["TRIGGER"!(^(0)["BULL")
- GOTO RIX^MCARDCN1
- XECUTE ^(1)
- SET X=DS
- GOTO IX
- +1 IF DIC(0)["E"&($ORDER(^DD(+DO(2),0,"ID",0))>0)!$DATA(DIC("DR"))
- GOTO ^MCARDCN1
- D ;
- +1 SET Y=DA_"^"_X_"^"_1
- if $DATA(D)#2
- SET DA=D
- GOTO R^MCARDC
- +2 ;
- INCR SET DIY=1
- IF $PIECE(DO,U,2)>1
- FOR MCPCT=1:1:$LENGTH($PIECE(X,".",2))
- SET DIY=DIY/10
- +1 QUIT
