- MCARDCQ ;WISC/TJK-MODIFIED DICQ ROUTINE FOR MEDICINE SCREENS ;8/23/96 12:33
- ;;2.3;Medicine;;09/13/1996
- S DZ=X D:DIC(0)]"" DQ S:$D(DZ) X=DZ K DZ,XQH G A^MCARDC
- ;
- DQ W ! D:'$D(DO) DO^MCARDC1 K DS,MCPCTY I DO="0^-1" K DO W " Pointed-to File does not exist!" Q
- S DD="",Y=$P(DO,U,4),DIY=DO,DIX=D D DIY
- S X=$S($D(^DD(+DO(2),.001,0)):$P(^(0),U,1),DIC(0)["N":"NUMBER",1:""),DIZ=X]"",DIW=^DD(+DO(2),.01,0)
- S DIW=$P(DIW,U,2,3) G:$D(^DD(+DO(2),0,"QUES")) @^("QUES") I DIZ S DS=.001 D DS
- IX I $D(MCBDIC),MCBDIC=DIC,$D(MCDF) S DIX=MCDF
- S X=$O(^DD(+DO(2),0,"IX",DIX,-1)) S:X="" X=-1 I X'<0 S DS=$O(^(X,0)) S:DS="" DS=-1 I $D(^DD(X,DS,0)) S MCPCT=$P(^(0),U,2,3),X=$P(^(0),U,1) D DS
- I @("$D("_DIC_"DIX))>9!$D(DF)"),DD="" S DD=DIX,DIW=$G(MCPCT) S:'Y Y=2 S:'$D(^(DD)) Y=0,DIZ=0 ; $G() ADDED BY rew 8/10/95
- S DIX=$O(@(DIC_"DIX)")) S:DIX="" DIX=-1 G IX:DIC(0)["M"&'DIX I DD="" S DIZ=1,YMLH=$O(^("AZ")) S:YMLH'=""&'YMLH Y=0
- I $D(DZ)#2 G C:DZ["??" S:DZ["BAD" Y=0
- W " ANSWER WITH ",$P(DO,U,1) S DS=0
- F X=1:1 S DS=$O(DS(DS)) S:DS="" DS=-1 Q:DS<0 W $P(", OR",U,X>1) W:$X+$L(DS(DS))>70 !?4 W " ",DS(DS) I $Y>21 R !,"Press <RETURN> to Continue: ",MCPCTY:DTIME X DJCP
- K DS W $E(":",Y) ;G 0:'Y
- 20 D DCS^MCARDNQ G C:Y<6 W !," DO YOU WANT THE ENTIRE " W:DO(2)'["s"&'$D(DIC("S"))&'$D(DF) Y,"-ENTRY " W $P(DO,U,1)," LIST" S MCPCT=0 D YN^MCARDCN S:MCPCT=1 MCPCTY=1 I MCPCTY'="??" S MCPCTY=$E(MCPCTY,2,99)
- G 0:MCPCT#2=0!(MCPCT<0&(MCPCTY="")),C:MCPCTY=""
- S DIZ=$S(+MCPCTY=MCPCTY:1,DD]"":0,1:DIZ) I +MCPCTY'=MCPCTY G 20:DD="" I $P(DIW,U,1)["D" S DS=Y,X=MCPCTY,%DT="T" D ^%DT K %DT S MCPCTY=Y,Y=DS,DIZ=0 I MCPCTY<0 W *7 G 20
- C I $Y>20 D CONT^MCARDCQ1 Q:MCPCTY=U X DJCP
- D DCS^MCARDNQ W:Y>1&(DZ'="???") !,"CHOOSE FROM:" S X=$P(" D S Q:$G(MCPCTY)=U I ",U,$D(DIC("S"))!$D(DO("SCR")))
- I DIZ S DS="I $D(^(Y,0))#2 S X=$P(^(0),""^"",1)"_X_" W"_$S(DO(2)'["D":"",1:":$L(Y)<8")_" Y,?$X+5-$L(Y),"" """,DIX="S Y=$O("_DIC_"Y)) S:Y="""" Y=-1 I Y'>0" G A
- S DIX="S X=$O("_DIC_""""_DD_""",X)) I X=""""",DS=$S(X]""!$D(DIC("W")):"F Y=0:0 S Y=$O("_DIC_""""_DD_""",X,Y)) S:Y="""" Y=-1 Q:Y<0 "_$P(" I $D(^(Y))#2,'^(Y)",1,DD="B")_" I $D("_DIC_"Y,0))"_X,1:"I 1")_" W:$X>5 !?3"
- A S X="X"
- D S Y=$P(DIW,U,1) I Y["D" S DIY=27,X=" S MCPCT="_X_" D DT" G ^MCARDCQ1
- I Y["P",$P(DIW,U,2)["(" S DIY=U_$P(DIW,U,2),X="$S($D("_DIY_X_",0))#2:$P(^(0),""^"",1),1:"_X_")" I @("$D("_DIY_"0))") S DIY=^(0) D DIY S DIW=$P(^(0),U,2,3) G D
- ;; ***ORIGINAL*** ;; I Y["S",Y[U S DS(95)=$P(DIW,U,2),X="$P($P(DS(95),"_X_"_"":"",2),"";"",1)"
- I Y["S" S DS(95)=$P(DIW,U,2),X="X_"" ""_$P($P(DS(95),"_X_"_"":"",2),"";"",1)"
- I Y["V" S X=" S MCPCTY=Y,Y=X,DJC=+DO(2) D Y^MCARDCM2 K DJC W Y S Y=MCPCTY" G ^MCARDCQ1
- S X=" W "_X
- M G ^MCARDCQ1
- ;
- 0 K DIW,DIZ,DS G 0^MCARDCQ1:DIC(0)["L" Q
- ;
- DIY S DIY=$P(^DD(+$P(DIY,U,2),.01,0),"$L(X)>",2),DIY=$S(DIY:DIY,1:30)+7 Q
- ;
- SOUNDEX S Y=0 G IX
- ;
- DS S:DO'[X DS(DS)=X
- Q
- MCARDCQ ;WISC/TJK-MODIFIED DICQ ROUTINE FOR MEDICINE SCREENS ;8/23/96 12:33
- +1 ;;2.3;Medicine;;09/13/1996
- +2 SET DZ=X
- IF DIC(0)]""
- DO DQ
- IF $DATA(DZ)
- SET X=DZ
- KILL DZ,XQH
- GOTO A^MCARDC
- +3 ;
- DQ WRITE !
- IF '$DATA(DO)
- DO DO^MCARDC1
- KILL DS,MCPCTY
- IF DO="0^-1"
- KILL DO
- WRITE " Pointed-to File does not exist!"
- QUIT
- +1 SET DD=""
- SET Y=$PIECE(DO,U,4)
- SET DIY=DO
- SET DIX=D
- DO DIY
- +2 SET X=$SELECT($DATA(^DD(+DO(2),.001,0)):$PIECE(^(0),U,1),DIC(0)["N":"NUMBER",1:"")
- SET DIZ=X]""
- SET DIW=^DD(+DO(2),.01,0)
- +3 SET DIW=$PIECE(DIW,U,2,3)
- IF $DATA(^DD(+DO(2),0,"QUES"))
- GOTO @^("QUES")
- IF DIZ
- SET DS=.001
- DO DS
- IX IF $DATA(MCBDIC)
- IF MCBDIC=DIC
- IF $DATA(MCDF)
- SET DIX=MCDF
- +1 SET X=$ORDER(^DD(+DO(2),0,"IX",DIX,-1))
- IF X=""
- SET X=-1
- IF X'<0
- SET DS=$ORDER(^(X,0))
- IF DS=""
- SET DS=-1
- IF $DATA(^DD(X,DS,0))
- SET MCPCT=$PIECE(^(0),U,2,3)
- SET X=$PIECE(^(0),U,1)
- DO DS
- +2 ; $G() ADDED BY rew 8/10/95
- IF @("$DCQ_source.html#xD">D("_DCQ_source.html#xD">DIC_"DCQ_source.html#xD">DIX))>9!$DCQ_source.html#xD">D(DCQ_source.html#xD">DF)")
- IF DD=""
- SET DD=DIX
- SET DIW=$GET(MCPCT)
- IF 'Y
- SET Y=2
- IF '$DATA(^(DD))
- SET Y=0
- SET DIZ=0
- +3 SET DIX=$ORDER(@(DIC_"DIX)"))
- IF DIX=""
- SET DIX=-1
- IF DIC(0)["M"&'DIX
- GOTO IX
- IF DD=""
- SET DIZ=1
- SET YMLH=$ORDER(^("AZ"))
- IF YMLH'=""&'YMLH
- SET Y=0
- +4 IF $DATA(DZ)#2
- IF DZ["??"
- GOTO C
- IF DZ["BAD"
- SET Y=0
- +5 WRITE " ANSWER WITH ",$PIECE(DO,U,1)
- SET DS=0
- +6 FOR X=1:1
- SET DS=$ORDER(DS(DS))
- IF DS=""
- SET DS=-1
- IF DS<0
- QUIT
- WRITE $PIECE(", OR",U,X>1)
- IF $X+$LENGTH(DS(DS))>70
- WRITE !?4
- WRITE " ",DS(DS)
- IF $Y>21
- READ !,"Press <RETURN> to Continue: ",MCPCTY:DTIME
- XECUTE DJCP
- +7 ;G 0:'Y
- KILL DS
- WRITE $EXTRACT(":",Y)
- 20 DO DCS^MCARDNQ
- IF Y<6
- GOTO C
- WRITE !," DO YOU WANT THE ENTIRE "
- IF DO(2)'["s"&'$DATA(DIC("S"))&'$DATA(DF)
- WRITE Y,"-ENTRY "
- WRITE $PIECE(DO,U,1)," LIST"
- SET MCPCT=0
- DO YN^MCARDCN
- IF MCPCT=1
- SET MCPCTY=1
- IF MCPCTY'="??"
- SET MCPCTY=$EXTRACT(MCPCTY,2,99)
- +1 IF MCPCT#2=0!(MCPCT<0&(MCPCTY=""))
- GOTO 0
- IF MCPCTY=""
- GOTO C
- +2 SET DIZ=$SELECT(+MCPCTY=MCPCTY:1,DD]"":0,1:DIZ)
- IF +MCPCTY'=MCPCTY
- IF DD=""
- GOTO 20
- IF $PIECE(DIW,U,1)["D"
- SET DS=Y
- SET X=MCPCTY
- SET %DT="T"
- DO ^%DT
- KILL %DT
- SET MCPCTY=Y
- SET Y=DS
- SET DIZ=0
- IF MCPCTY<0
- WRITE *7
- GOTO 20
- C IF $Y>20
- DO CONT^MCARDCQ1
- IF MCPCTY=U
- QUIT
- XECUTE DJCP
- +1 DO DCS^MCARDNQ
- IF Y>1&(DZ'="???")
- WRITE !,"CHOOSE FROM:"
- SET X=$PIECE(" D S Q:$G(MCPCTY)=U I ",U,$DATA(DIC("S"))!$DATA(DO("SCR")))
- +2 IF DIZ
- SET DS="I $D(^(Y,0))#2 S X=$P(^(0),""^"",1)"_X_" W"_$SELECT(DO(2)'["D":"",1:":$L(Y)<8")_" Y,?$X+5-$L(Y),"" """
- SET DIX="S Y=$O("_DIC_"Y)) S:Y="""" Y=-1 I Y'>0"
- GOTO A
- +3 SET DIX="S X=$O("_DIC_""""_DD_""",X)) I X="""""
- SET DCQ_source.html#xD">DS=$SELECT(X]""!$DCQ_source.html#xD">DATA(DCQ_source.html#xD">DIC("W")):"F Y=0:0 S Y=$O("_DCQ_source.html#xD">DIC_""""_DCQ_source.html#xD">DDCQ_source.html#xD">D_""",X,Y)) S:Y="""" Y=-1 Q:Y<0 "_$PIECE(" I $DCQ_source.html#xD">D(^(Y))#2,'^(Y)",1,DCQ_source.html#xD">DDCQ_source.html#xD">D="B")_" I $DCQ_source.html#xD">D("_DCQ_source.html#xD">DIC_"Y,0))"_X,1:"I 1")_" W:$X>5 !?3"
- A SET X="X"
- D SET Y=$PIECE(DIW,U,1)
- IF Y["D"
- SET DIY=27
- SET X=" S MCPCT="_X_" D DT"
- GOTO ^MCARDCQ1
- +1 IF Y["P"
- IF $PIECE(DIW,U,2)["("
- SET DIY=U_$PIECE(DIW,U,2)
- SET X="$S($D("_DIY_X_",0))#2:$P(^(0),""^"",1),1:"_X_")"
- IF @("$D("_DIY_"0))")
- SET DIY=^(0)
- DO DIY
- SET DIW=$PIECE(^(0),U,2,3)
- GOTO D
- +2 ;; ***ORIGINAL*** ;; I Y["S",Y[U S DS(95)=$P(DIW,U,2),X="$P($P(DS(95),"_X_"_"":"",2),"";"",1)"
- +3 IF Y["S"
- SET DS(95)=$PIECE(DIW,U,2)
- SET X="X_"" ""_$P($P(DS(95),"_X_"_"":"",2),"";"",1)"
- +4 IF Y["V"
- SET X=" S MCPCTY=Y,Y=X,DJC=+DO(2) D Y^MCARDCM2 K DJC W Y S Y=MCPCTY"
- GOTO ^MCARDCQ1
- +5 SET X=" W "_X
- M GOTO ^MCARDCQ1
- +1 ;
- 0 KILL DIW,DIZ,DS
- IF DIC(0)["L"
- GOTO 0^MCARDCQ1
- QUIT
- +1 ;
- DIY SET DIY=$PIECE(^DD(+$PIECE(DIY,U,2),.01,0),"$L(X)>",2)
- SET DIY=$SELECT(DIY:DIY,1:30)+7
- QUIT
- +1 ;
- SOUNDEX SET Y=0
- GOTO IX
- +1 ;
- DS IF DO'[X
- SET DS(DS)=X
- +1 QUIT
