- MDPS5 ; HOIFO/NCA - Retrieve List of Consult Procedures for RDV ;3/4/05 13:29
- ;;1.0;CLINICAL PROCEDURES;**13**;Apr 01, 2004;Build 19
- ; Integration Agreements:
- ; Reference IA# 2740 [Subscription] Routine GMRCSLM1.
- ; IA# 2944 [Subscription] Calls to TIUSRVR1.
- ; IA# 3067 [Private] Read fields in Consult file (#123) w/FM
- ;
- GP(MDDFN,MDSDT,MDEDT) ; Gather the completed procedure list
- N MDCPR,MDCK,MDCPRO,MDCX,MDDTE,MDLP,MDFIL,MDSTK,MDX4 S MDFIL=123,MDSTK="2,9"
- D OER^GMRCSLM1(MDDFN,"",MDSDT,MDEDT,MDSTK,1)
- I $G(^TMP("GMRCR",$J,"CS",1,0))["< PATIENT DOES NOT HAVE ANY CONSULTS/REQUESTS" Q
- S MDLP="" F S MDLP=$O(^TMP("GMRCR",$J,"CS",MDLP)) Q:MDLP="AD" S MDX=$G(^(MDLP,0)) D
- .S MDCPRO=$P(MDX,U,5),MDX=+MDX
- .Q:$$GET1^DIQ(MDFIL,+MDX_",",13,"I")'="P"
- .S MDCPR=$$GET1^DIQ(MDFIL,+MDX_",",4,"I")
- .Q:MDCPR'["GMR(123.3"
- .S MDCPR=+MDCPR S MDFIL=123.3 Q:'$$GET1^DIQ(MDFIL,+MDCPR_",",.05,"I")
- .Q:$O(^MDD(702,"ACON",+MDX,0))
- .S MDFIL=123 K MDCX D GETS^DIQ(MDFIL,+MDX_",","50*","I","MDCX")
- .S MDCK="" F S MDCK=$O(MDCX(123.03,MDCK)) Q:MDCK<1 S MDX4=$G(MDCX(123.03,MDCK,.01,"I")) D
- ..I MDX4["TIU" D
- ...S MDFIL=8925,MDDTE=$$GET1^DIQ(MDFIL,+MDX4_",",1201,"I")
- ...S Y=MDDTE X ^DD("DD") N MDREV S MDREV=(9999999.9999-MDDTE)
- ...S:$G(^TMP("MDPLST",$J,MDCPRO,MDREV_"^"_+MDX4))="" ^(MDREV_"^"_+MDX4)=MDCPRO_"^"_+MDX4_"^"_"PRPRO"_"^"_"MDPS4"_"^^"_Y_"^^^^^"_MDCPRO_"^^"_+MDX_"^"_+MDX4,MDFIL=123
- ...Q
- ..Q
- .Q
- K ^TMP("GMRCR",$J,"CS")
- Q
- PRPRO ; Return the Result Text for File Consult Procedure records
- Q:'$G(MCARGDA)
- N FFF,MDCLIN,MDCON,MDF,MDIMG,MDMCG,MDMED,MDREC,MDPRILV,MDPTR,MDSTUDY,MDTIU,MDX4,PATID,MDRPG,RESULTS
- I '$G(MDALL) K ^TMP("MDPTXT",$J)
- S MDIMG=0,$P(FFF,"-",80)="",MDRPG=0,MDF=123
- S MDSTUDY=+$G(MCARGDA)
- S (MDPRILV,RESULTS)="",MDCLIN=0
- I +MDPRILV D TGET^TIUSRVR1(.RESULTS,+MDSTUDY) M ^TMP("MDPTXT",$J,MCARGDA,MCPRO)=@RESULTS K ^TMP("TIUVIEW",$J) Q:+$G(MDALL)
- S:+MDPRILV<1 ^TMP("MDPTXT",$J,MCARGDA,MCPRO,1)=$P(MDPRILV,U,2)
- NXT Q:+$G(MDALL) Q:+$G(MDRDV)
- I $D(ORHFS) U IO G PRINT^MDPS1
- G PRINT^MDPS1
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMDPS5 2060 printed Mar 13, 2025@20:48:35 Page 2
- MDPS5 ; HOIFO/NCA - Retrieve List of Consult Procedures for RDV ;3/4/05 13:29
- +1 ;;1.0;CLINICAL PROCEDURES;**13**;Apr 01, 2004;Build 19
- +2 ; Integration Agreements:
- +3 ; Reference IA# 2740 [Subscription] Routine GMRCSLM1.
- +4 ; IA# 2944 [Subscription] Calls to TIUSRVR1.
- +5 ; IA# 3067 [Private] Read fields in Consult file (#123) w/FM
- +6 ;
- GP(MDDFN,MDSDT,MDEDT) ; Gather the completed procedure list
- +1 NEW MDCPR,MDCK,MDCPRO,MDCX,MDDTE,MDLP,MDFIL,MDSTK,MDX4
- SET MDFIL=123
- SET MDSTK="2,9"
- +2 DO OER^GMRCSLM1(MDDFN,"",MDSDT,MDEDT,MDSTK,1)
- +3 IF $GET(^TMP("GMRCR",$JOB,"CS",1,0))["< PATIENT DOES NOT HAVE ANY CONSULTS/REQUESTS"
- QUIT
- +4 SET MDLP=""
- FOR
- SET MDLP=$ORDER(^TMP("GMRCR",$JOB,"CS",MDLP))
- if MDLP="AD"
- QUIT
- SET MDX=$GET(^(MDLP,0))
- Begin DoDot:1
- +5 SET MDCPRO=$PIECE(MDX,U,5)
- SET MDX=+MDX
- +6 if $$GET1^DIQ(MDFIL,+MDX_",",13,"I")'="P"
- QUIT
- +7 SET MDCPR=$$GET1^DIQ(MDFIL,+MDX_",",4,"I")
- +8 if MDCPR'["GMR(123.3"
- QUIT
- +9 SET MDCPR=+MDCPR
- SET MDFIL=123.3
- if '$$GET1^DIQ(MDFIL,+MDCPR_",",.05,"I")
- QUIT
- +10 if $ORDER(^MDD(702,"ACON",+MDX,0))
- QUIT
- +11 SET MDFIL=123
- KILL MDCX
- DO GETS^DIQ(MDFIL,+MDX_",","50*","I","MDCX")
- +12 SET MDCK=""
- FOR
- SET MDCK=$ORDER(MDCX(123.03,MDCK))
- if MDCK<1
- QUIT
- SET MDX4=$GET(MDCX(123.03,MDCK,.01,"I"))
- Begin DoDot:2
- +13 IF MDX4["TIU"
- Begin DoDot:3
- +14 SET MDFIL=8925
- SET MDDTE=$$GET1^DIQ(MDFIL,+MDX4_",",1201,"I")
- +15 SET Y=MDDTE
- XECUTE ^DD("DD")
- NEW MDREV
- SET MDREV=(9999999.9999-MDDTE)
- +16 if $GET(^TMP("MDPLST",$JOB,MDCPRO,MDREV_"^"_+MDX4))=""
- SET ^(MDREV_"^"_+MDX4)=MDCPRO_"^"_+MDX4_"^"_"PRPRO"_"^"_"MDPS4"_"^^"_Y_"^^^^^"_MDCPRO_"^^"_+MDX_"^"_+MDX4
- SET MDFIL=123
- +17 QUIT
- End DoDot:3
- +18 QUIT
- End DoDot:2
- +19 QUIT
- End DoDot:1
- +20 KILL ^TMP("GMRCR",$JOB,"CS")
- +21 QUIT
- PRPRO ; Return the Result Text for File Consult Procedure records
- +1 if '$GET(MCARGDA)
- QUIT
- +2 NEW FFF,MDCLIN,MDCON,MDF,MDIMG,MDMCG,MDMED,MDREC,MDPRILV,MDPTR,MDSTUDY,MDTIU,MDX4,PATID,MDRPG,RESULTS
- +3 IF '$GET(MDALL)
- KILL ^TMP("MDPTXT",$JOB)
- +4 SET MDIMG=0
- SET $PIECE(FFF,"-",80)=""
- SET MDRPG=0
- SET MDF=123
- +5 SET MDSTUDY=+$GET(MCARGDA)
- +6 SET (MDPRILV,RESULTS)=""
- SET MDCLIN=0
- +7 IF +MDPRILV
- DO TGET^TIUSRVR1(.RESULTS,+MDSTUDY)
- MERGE ^TMP("MDPTXT",$JOB,MCARGDA,MCPRO)=@RESULTS
- KILL ^TMP("TIUVIEW",$JOB)
- if +$GET(MDALL)
- QUIT
- +8 if +MDPRILV<1
- SET ^TMP("MDPTXT",$JOB,MCARGDA,MCPRO,1)=$PIECE(MDPRILV,U,2)
- NXT if +$GET(MDALL)
- QUIT
- if +$GET(MDRDV)
- QUIT
- +1 IF $DATA(ORHFS)
- USE IO
- GOTO PRINT^MDPS1
- +2 GOTO PRINT^MDPS1
