MDPS4 ; HOIFO/NCA - Retrieve List of Consult Procedures ;1/26/06 12:45
;;1.0;CLINICAL PROCEDURES;**13,24**;Apr 01, 2004;Build 8
; Integration Agreements:
; Reference IA# 2740 [Subscription] Routine GMRCSLM1.
; IA# 2693 [Subscription] TIU Extractions.
; IA# 2944 [Subscription] Calls to TIUSRVR1.
; IA# 3067 [Private] Read fields in Consult file (#123) w/FM
; IA# 4792 [Private] CANDO^TIUSRVA call
;
GP(MDDFN,MDSDT,MDEDT) ; Gather the completed procedure list
N MDCPR,MDCK,MDCPRO,MDCX,MDDTE,MDLP,MDFIL,MDX4,MDSTK,MDX S MDSTK="2,9",MDFIL=123
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=0 F S MDLP=$O(^TMP("GMRCR",$J,"CS",MDLP)) Q:MDLP="AD"!(MDLP<1) S MDX=$G(^(MDLP,0)) D
.S MDCPRO=$P(MDX,U,5),MDX=+MDX
.Q:$$GET1^DIQ(MDFIL,+MDX_",",13,"I")'="P"
.;S MDFIL=123,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,MDREV,MDCPRO_"~"_+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,MDCK1,MDCLIN,MDCON,MDFIL,MDIMG,MDLCT,MDMCG,MDMED,MDNAME,MDREC,MDPRILV,MDPTR,MDSTUDY,MDTIM,MDTIU,MDTL,MDX4,PATID,MDRPG,RESULTS,MDXX,X
I '$G(MDALL) K ^TMP("MDPTXT",$J)
K ^TMP("MDTMPT",$J) D NOW^%DTC S X=% D DTIME^MCARP S MDTIM=$$FMTE^XLFDT(X,2) K %
S MDIMG=0,$P(FFF,"-",80)="",(MDLCT,MDRPG)=0,MDF=123
S MDSTUDY=+$G(MCARGDA)
S (MDPRILV,RESULTS)="",MDCLIN=0
D CANDO^TIUSRVA(.MDPRILV,+MDSTUDY,"VIEW")
I +MDPRILV D TGET^TIUSRVR1(.RESULTS,+MDSTUDY) M ^TMP("MDTMPT",$J,MCARGDA,MCPRO)=@RESULTS K ^TMP("TIUVIEW",$J) Q:+$G(MDALL)
S:+MDPRILV<1 ^TMP("MDTMPT",$J,MCARGDA,MCPRO,1)=$P(MDPRILV,U,2)
K ^TMP("MDTIUST",$J) N MDTIUER,MDTST S (MDNAME,MDTIUER,MDTST)=""
D EXTRACT^TIULQ(+MDSTUDY,"^TMP(""MDTIUST"",$J)",MDTIUER,".01;.02;1405","IE") Q:+MDTIUER
S MDTST=$G(^TMP("MDTIUST",$J,+MDSTUDY,1405,"I")),MDTST=$S(MDTST["GMR(123":+MDTST,1:0)
S MDNAME=$G(^TMP("MDTIUST",$J,+MDSTUDY,.02,"E")),MDRPG=MDRPG+1
S MDXX=$G(^TMP("MDTIUST",$J,+MDSTUDY,.01,"E"))
S MDFIL=123 S MDTL=$S(+MDTST:$$GET1^DIQ(MDFIL,+MDTST_",",4,"E"),1:MDXX)
I '$G(MDHDR) D
.S MDLCT=MDLCT+1,^TMP("MDPTXT",$J,MCARGDA,MCPRO,MDLCT)="Pg. "_MDRPG_$J(" ",25)_$$HOSP^MDPS2(DFN)_$J(" ",25)_MDTIM
.S MDLCT=MDLCT+1 S ^TMP("MDPTXT",$J,MCARGDA,MCPRO,MDLCT)=$J(" ",25)_MDTL
.S MDLCT=MDLCT+1 S ^TMP("MDPTXT",$J,MCARGDA,MCPRO,MDLCT)=$$DEMO^MDPS2(DFN)
.S MDLCT=MDLCT+1 S ^TMP("MDPTXT",$J,MCARGDA,MCPRO,MDLCT)=FFF
S MDCK1="" F S MDCK1=$O(^TMP("MDTMPT",$J,MCARGDA,MCPRO,MDCK1)) Q:MDCK1<1 S MDXX=$G(^(MDCK1)),MDLCT=MDLCT+1,^TMP("MDPTXT",$J,MCARGDA,MCPRO,MDLCT)=MDXX
K ^TMP("MDTMPT",$J,MCARGDA,MCPRO)
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[HMDPS4 3312 printed Sep 23, 2025@19:19:55 Page 2
MDPS4 ; HOIFO/NCA - Retrieve List of Consult Procedures ;1/26/06 12:45
+1 ;;1.0;CLINICAL PROCEDURES;**13,24**;Apr 01, 2004;Build 8
+2 ; Integration Agreements:
+3 ; Reference IA# 2740 [Subscription] Routine GMRCSLM1.
+4 ; IA# 2693 [Subscription] TIU Extractions.
+5 ; IA# 2944 [Subscription] Calls to TIUSRVR1.
+6 ; IA# 3067 [Private] Read fields in Consult file (#123) w/FM
+7 ; IA# 4792 [Private] CANDO^TIUSRVA call
+8 ;
GP(MDDFN,MDSDT,MDEDT) ; Gather the completed procedure list
+1 NEW MDCPR,MDCK,MDCPRO,MDCX,MDDTE,MDLP,MDFIL,MDX4,MDSTK,MDX
SET MDSTK="2,9"
SET MDFIL=123
+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=0
FOR
SET MDLP=$ORDER(^TMP("GMRCR",$JOB,"CS",MDLP))
if MDLP="AD"!(MDLP<1)
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 ;S MDFIL=123,MDCPR=$$GET1^DIQ(MDFIL,+MDX_",",4,"I")
+8 ;Q:MDCPR'["GMR(123.3"
+9 ;S MDCPR=+MDCPR S MDFIL=123.3 Q:'$$GET1^DIQ(MDFIL,+MDCPR_",",.05,"I")
+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,MDREV,MDCPRO_"~"_+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,MDCK1,MDCLIN,MDCON,MDFIL,MDIMG,MDLCT,MDMCG,MDMED,MDNAME,MDREC,MDPRILV,MDPTR,MDSTUDY,MDTIM,MDTIU,MDTL,MDX4,PATID,MDRPG,RESULTS,MDXX,X
+3 IF '$GET(MDALL)
KILL ^TMP("MDPTXT",$JOB)
+4 KILL ^TMP("MDTMPT",$JOB)
DO NOW^%DTC
SET X=%
DO DTIME^MCARP
SET MDTIM=$$FMTE^XLFDT(X,2)
KILL %
+5 SET MDIMG=0
SET $PIECE(FFF,"-",80)=""
SET (MDLCT,MDRPG)=0
SET MDF=123
+6 SET MDSTUDY=+$GET(MCARGDA)
+7 SET (MDPRILV,RESULTS)=""
SET MDCLIN=0
+8 DO CANDO^TIUSRVA(.MDPRILV,+MDSTUDY,"VIEW")
+9 IF +MDPRILV
DO TGET^TIUSRVR1(.RESULTS,+MDSTUDY)
MERGE ^TMP("MDTMPT",$JOB,MCARGDA,MCPRO)=@RESULTS
KILL ^TMP("TIUVIEW",$JOB)
if +$GET(MDALL)
QUIT
+10 if +MDPRILV<1
SET ^TMP("MDTMPT",$JOB,MCARGDA,MCPRO,1)=$PIECE(MDPRILV,U,2)
+11 KILL ^TMP("MDTIUST",$JOB)
NEW MDTIUER,MDTST
SET (MDNAME,MDTIUER,MDTST)=""
+12 DO EXTRACT^TIULQ(+MDSTUDY,"^TMP(""MDTIUST"",$J)",MDTIUER,".01;.02;1405","IE")
if +MDTIUER
QUIT
+13 SET MDTST=$GET(^TMP("MDTIUST",$JOB,+MDSTUDY,1405,"I"))
SET MDTST=$SELECT(MDTST["GMR(123":+MDTST,1:0)
+14 SET MDNAME=$GET(^TMP("MDTIUST",$JOB,+MDSTUDY,.02,"E"))
SET MDRPG=MDRPG+1
+15 SET MDXX=$GET(^TMP("MDTIUST",$JOB,+MDSTUDY,.01,"E"))
+16 SET MDFIL=123
SET MDTL=$SELECT(+MDTST:$$GET1^DIQ(MDFIL,+MDTST_",",4,"E"),1:MDXX)
+17 IF '$GET(MDHDR)
Begin DoDot:1
+18 SET MDLCT=MDLCT+1
SET ^TMP("MDPTXT",$JOB,MCARGDA,MCPRO,MDLCT)="Pg. "_MDRPG_$JUSTIFY(" ",25)_$$HOSP^MDPS2(DFN)_$JUSTIFY(" ",25)_MDTIM
+19 SET MDLCT=MDLCT+1
SET ^TMP("MDPTXT",$JOB,MCARGDA,MCPRO,MDLCT)=$JUSTIFY(" ",25)_MDTL
+20 SET MDLCT=MDLCT+1
SET ^TMP("MDPTXT",$JOB,MCARGDA,MCPRO,MDLCT)=$$DEMO^MDPS2(DFN)
+21 SET MDLCT=MDLCT+1
SET ^TMP("MDPTXT",$JOB,MCARGDA,MCPRO,MDLCT)=FFF
End DoDot:1
+22 SET MDCK1=""
FOR
SET MDCK1=$ORDER(^TMP("MDTMPT",$JOB,MCARGDA,MCPRO,MDCK1))
if MDCK1<1
QUIT
SET MDXX=$GET(^(MDCK1))
SET MDLCT=MDLCT+1
SET ^TMP("MDPTXT",$JOB,MCARGDA,MCPRO,MDLCT)=MDXX
+23 KILL ^TMP("MDTMPT",$JOB,MCARGDA,MCPRO)
NXT if +$GET(MDALL)
QUIT
if +$GET(MDRDV)
QUIT
+1 IF $DATA(ORHFS)
USE IO
GOTO PRINT^MDPS1
+2 GOTO PRINT^MDPS1
