- MCARDSS ;WISC/RMP-DECISION SUPPORT INTERFACE ;5/5/95 08:01
- ;;2.3;Medicine;;09/13/1996
- START(STDATE,ENDATE) ;REMOVE NEW OF SAME AND HARD SET OF SAME
- N TYPE,COUNT,CPTIEN,FILE,CDATE,IEN
- N MCARP,MCDHD,MCESKEY,MCESON,MCESS,MCESSES,MCPATFLD,MCPRO,MCOPT
- N PROC,OPTION,DIR,Y,DTOUT,DIRUT,DIROUT,DUOUT,DHIT,DIOEND,DIROUR
- S (MCARP)="",COUNT=0
- S TYPE="" ;"P" ;should be third input parameter
- K ^TMP($J)
- F S MCARP=$O(^MCAR(694.8,"PS",MCARP)) Q:MCARP'?1N.N D
- .S CPTIEN="" F S CPTIEN=$O(^MCAR(694.8,"PS",MCARP,CPTIEN)) Q:CPTIEN'?1N.N D
- ..N CPT
- ..S CPT=$$CPT(CPTIEN) Q:CPT=""
- ..D PROC(.MCARP,.MCESON,.MCESKEY,.MCPATFLD,.FILE,.MCPRO)
- ..Q:MCESON'=1
- ..S MCOPT=1 D PIEN
- ..Q
- Q
- CPT(IEN) ;
- N TEMP,CPT
- S CPT=""
- I $D(^MCAR(694.8,IEN,1,0)) S TEMP=0 D
- .F Q:CPT?1N.N S TEMP=$O(^MCAR(694.8,IEN,1,TEMP)) Q:TEMP'?1N.N D
- ..I $P($P(^(TEMP,0),U),";",2)["ICPT(" S CPT=$P($P(^(0),U),";")
- ..Q
- Q CPT
- PIEN ;
- N IEN,CDATE,PROV,FMDT
- S CDATE=$O(^MCAR(FILE,"B",STDATE),-1)
- F S IEN=$$NEXTD(FILE,ENDATE,.CDATE,MCOPT) Q:IEN="" D
- .S PROV=$P(^MCAR(FILE,IEN,"ES"),U,4)
- .S FMDT=$P(^MCAR(FILE,IEN,0),U)
- .Q:(+PROV=0)!(+FMDT=0)
- .S COUNT=COUNT+1
- .;W !,"200^2^FMDT,CPT: ",PROV_U_$$DFN(FILE,IEN,MCPATFLD)_U_FMDT_U_CPT
- .S ^TMP($J,COUNT)=PROV_U_$$DFN(FILE,IEN,MCPATFLD)_U_FMDT_U_CPT
- Q
- DFN(FILE,IEN,MCPATFLD) ;
- N TEMP
- S TEMP=$P(^DD(FILE,MCPATFLD,0),U,4)
- Q $P(^MCAR(FILE,IEN,$P(TEMP,";")),U,$P(TEMP,";",2))
- TEST(REC,OPT,FILE) ;Screens out information
- N STATUS,TEST
- S STATUS=$P($G(^MCAR(FILE,REC,"ES")),U,7) S:STATUS="" STATUS="D"
- S TEST=OPT+$S(STATUS["D":1,1:0)
- Q $S(STATUS="S":0,OPT=3:1,TEST=1:1,TEST=3:1,1:0)
- PROC(MCARP,MCESON,MCESKEY,MCPATFLD,FILE,MCPRO) ;
- N TEMP
- S TEMP=$G(^MCAR(697.2,MCARP,0)),MCESS=0
- S MCESON=+$P(TEMP,U,14),MCESKEY=$P(TEMP,U,15)
- S MCPATFLD=$P(TEMP,U,12)
- S MCESSES=$S(MCESON:1,1:0)
- S FILE=$P($P(TEMP,U,2),"(",2)
- S MCPRO=$P(TEMP,U)
- Q
- NEXTD(FILE,ENDATE,CDATE,MCOPT) ;
- N IEN
- S IEN=""
- F Q:IEN'="" S CDATE=$O(^MCAR(FILE,"B",CDATE)) Q:(CDATE="")!(CDATE>ENDATE) D
- .S IEN=$O(^MCAR(FILE,"B",CDATE,""))
- .S:'$$TEST(IEN,MCOPT,FILE) IEN=""
- .Q
- Q IEN
- MCARDSS ;WISC/RMP-DECISION SUPPORT INTERFACE ;5/5/95 08:01
- +1 ;;2.3;Medicine;;09/13/1996
- START(STDATE,ENDATE) ;REMOVE NEW OF SAME AND HARD SET OF SAME
- +1 NEW TYPE,COUNT,CPTIEN,FILE,CDATE,IEN
- +2 NEW MCARP,MCDHD,MCESKEY,MCESON,MCESS,MCESSES,MCPATFLD,MCPRO,MCOPT
- +3 NEW PROC,OPTION,DIR,Y,DTOUT,DIRUT,DIROUT,DUOUT,DHIT,DIOEND,DIROUR
- +4 SET (MCARP)=""
- SET COUNT=0
- +5 ;"P" ;should be third input parameter
- SET TYPE=""
- +6 KILL ^TMP($JOB)
- +7 FOR
- SET MCARP=$ORDER(^MCAR(694.8,"PS",MCARP))
- IF MCARP'?1N.N
- QUIT
- Begin DoDot:1
- +8 SET CPTIEN=""
- FOR
- SET CPTIEN=$ORDER(^MCAR(694.8,"PS",MCARP,CPTIEN))
- IF CPTIEN'?1N.N
- QUIT
- Begin DoDot:2
- +9 NEW CPT
- +10 SET CPT=$$CPT(CPTIEN)
- IF CPT=""
- QUIT
- +11 DO PROC(.MCARP,.MCESON,.MCESKEY,.MCPATFLD,.FILE,.MCPRO)
- +12 IF MCESON'=1
- QUIT
- +13 SET MCOPT=1
- DO PIEN
- +14 QUIT
- End DoDot:2
- End DoDot:1
- +15 QUIT
- CPT(IEN) ;
- +1 NEW TEMP,CPT
- +2 SET CPT=""
- +3 IF $DATA(^MCAR(694.8,IEN,1,0))
- SET TEMP=0
- Begin DoDot:1
- +4 FOR
- IF CPT?1N.N
- QUIT
- SET TEMP=$ORDER(^MCAR(694.8,IEN,1,TEMP))
- IF TEMP'?1N.N
- QUIT
- Begin DoDot:2
- +5 IF $PIECE($PIECE(^(TEMP,0),U),";",2)["ICPT("
- SET CPT=$PIECE($PIECE(^(0),U),";")
- +6 QUIT
- End DoDot:2
- End DoDot:1
- +7 QUIT CPT
- PIEN ;
- +1 NEW IEN,CDATE,PROV,FMDT
- +2 SET CDATE=$ORDER(^MCAR(FILE,"B",STDATE),-1)
- +3 FOR
- SET IEN=$$NEXTD(FILE,ENDATE,.CDATE,MCOPT)
- IF IEN=""
- QUIT
- Begin DoDot:1
- +4 SET PROV=$PIECE(^MCAR(FILE,IEN,"ES"),U,4)
- +5 SET FMDT=$PIECE(^MCAR(FILE,IEN,0),U)
- +6 IF (+PROV=0)!(+FMDT=0)
- QUIT
- +7 SET COUNT=COUNT+1
- +8 ;W !,"200^2^FMDT,CPT: ",PROV_U_$$DFN(FILE,IEN,MCPATFLD)_U_FMDT_U_CPT
- +9 SET ^TMP($JOB,COUNT)=PROV_U_$$DFN(FILE,IEN,MCPATFLD)_U_FMDT_U_CPT
- End DoDot:1
- +10 QUIT
- DFN(FILE,IEN,MCPATFLD) ;
- +1 NEW TEMP
- +2 SET TEMP=$PIECE(^DD(FILE,MCPATFLD,0),U,4)
- +3 QUIT $PIECE(^MCAR(FILE,IEN,$PIECE(TEMP,";")),U,$PIECE(TEMP,";",2))
- TEST(REC,OPT,FILE) ;Screens out information
- +1 NEW STATUS,TEST
- +2 SET STATUS=$PIECE($GET(^MCAR(FILE,REC,"ES")),U,7)
- IF STATUS=""
- SET STATUS="D"
- +3 SET TEST=OPT+$SELECT(STATUS["D":1,1:0)
- +4 QUIT $SELECT(STATUS="S":0,OPT=3:1,TEST=1:1,TEST=3:1,1:0)
- PROC(MCARP,MCESON,MCESKEY,MCPATFLD,FILE,MCPRO) ;
- +1 NEW TEMP
- +2 SET TEMP=$GET(^MCAR(697.2,MCARP,0))
- SET MCESS=0
- +3 SET MCESON=+$PIECE(TEMP,U,14)
- SET MCESKEY=$PIECE(TEMP,U,15)
- +4 SET MCPATFLD=$PIECE(TEMP,U,12)
- +5 SET MCESSES=$SELECT(MCESON:1,1:0)
- +6 SET FILE=$PIECE($PIECE(TEMP,U,2),"(",2)
- +7 SET MCPRO=$PIECE(TEMP,U)
- +8 QUIT
- NEXTD(FILE,ENDATE,CDATE,MCOPT) ;
- +1 NEW IEN
- +2 SET IEN=""
- +3 FOR
- IF IEN'=""
- QUIT
- SET CDATE=$ORDER(^MCAR(FILE,"B",CDATE))
- IF (CDATE="")!(CDATE>ENDATE)
- QUIT
- Begin DoDot:1
- +4 SET IEN=$ORDER(^MCAR(FILE,"B",CDATE,""))
- +5 IF '$$TEST(IEN,MCOPT,FILE)
- SET IEN=""
- +6 QUIT
- End DoDot:1
- +7 QUIT IEN
