- MDPS3 ; HOIFO/NCA - Remote Data View Data Retriever for CP ;8/26/05 14:37
- ;;1.0;CLINICAL PROCEDURES;**2,5,13,24**;Apr 01, 2004;Build 8
- ; Integration Agreements:
- ; Reference IA# 2693 [Subscription] TIU Extractions.
- ; 3067 [Private] Read fields in Consult file (#123) w/FM
- ; 10104 [Supported] Routine XLFSTR calls.
- ; 875 [Subscription] Access Order Status file (#100.01)
- ;
- GET702(MDGLO,MDDFN,MDC,MDSDT,MDEDT,MDMAX) ; Gather the new 702 entries
- N MDARR,MDCON,MDDTE,MDLP,MDCODE,MDCTRR,MDPROC,MDSTAT,MDX
- D GP^MDPS5(MDDFN,MDSDT,MDEDT) S MDCTRR=0
- S MDLP="" F S MDLP=$O(^MDD(702,"B",MDDFN,MDLP),-1) Q:MDLP<1 D
- .S MDX=$G(^MDD(702,MDLP,0)) Q:$P(MDX,"^",9)'=3
- .S MDPROC=$$GET1^DIQ(702,MDLP_",",.04,"E") Q:MDPROC=""
- .Q:'$P(MDX,U,6)
- .K ^TMP("MDTIUST",$J) S MDTIUER=""
- .D EXTRACT^TIULQ($P(MDX,U,6),"^TMP(""MDTIUST"",$J)",MDTIUER,".01;.05;70201;70202") Q:+MDTIUER
- .S MDCODE=$G(^TMP("MDTIUST",$J,$P(MDX,U,6),70201,"E"))
- .S:MDCODE'="" MDCODE=$$UP^XLFSTR(MDCODE)
- .I $G(MDC)'="" Q:MDCODE'=$G(MDC)
- .S MDDTE=$G(^TMP("MDTIUST",$J,$P(MDX,U,6),70202,"I"))
- .S MDSTAT=$G(^TMP("MDTIUST",$J,$P(MDX,U,6),.05,"E"))
- .S:'MDDTE MDDTE=$$GET1^DIQ(702,MDLP_",",.02,"I")
- .K ^TMP("MDTIUST",$J)
- .S MDCON=$P(MDX,U,5)
- .I +$G(MDMAX) Q:MDCTRR=MDMAX
- .I +$G(MDSDT) Q:MDDTE<+$G(MDSDT)
- .I +$G(MDEDT) Q:MDDTE>+$G(MDEDT)
- .I MDCON D Q:MDSTAT'="COMPLETE"&(MDSTAT'="PARTIAL RESULTS")
- ..S MDSTAT=$$GET1^DIQ(123,MDCON_",",8,"E")
- ..I MDSTAT="" S MDSTAT=$$GET1^DIQ(123,MDCON_",",8,"I") S:+MDSTAT MDSTAT=$$GET1^DIQ(100.01,MDSTAT_",",.01,"E")
- ..Q
- .S Y=MDDTE X ^DD("DD") N MDREV S MDREV=(9999999.9999-MDDTE)
- .I MDCON Q:$G(MDARR(MDCON))'="" S MDARR(MDCON)=MDCON
- .S:$G(^TMP("MDPLST",$J,MDPROC,MDREV_"~"_MDLP))="" ^(MDREV_"~"_MDLP)=MDPROC_"^"_MDLP_"^"_"PR702"_"^"_"MDPS1"_"^^"_Y_"^"_MDCODE_"^^^^"_MDPROC_"^^"_MDCON_"^"_+$P(MDX,U,6)
- .S MDCTRR=MDCTRR+1
- .Q
- K MDARR
- Q
- PRO(RESULT) ; Function to return info on single procedure.
- ;
- ; RESULT = variable pointer to a medicine file
- ; (e.g. "12;MCAR(691.5,") (required)
- N MDVAL,LL,S3,S4,S5
- S S3=+RESULT,S4=$P(RESULT,";",2),S4=$P(S4,",")
- I S4="MCAR(702.7" Q ""
- I S4="MCAR(699" S LL=$P($G(^MCAR(699,+S3,0)),U,12),MDVAL=$P($G(^MCAR(697.2,+LL,0)),U) Q MDVAL
- I S4="MCAR(699.5" S LL=$P($G(^MCAR(699.5,+S3,0)),U,6),MDVAL=$P($G(^MCAR(697.2,+LL,0)),U) Q MDVAL
- I S4="MCAR(694" S LL=$P($G(^MCAR(699.5,+S3,0)),U,6),MDVAL=$P($G(^MCAR(697.2,+LL,0)),U) Q MDVAL
- S LL=$O(^MCAR(697.2,"C",S4,0)),MDVAL=$P(^MCAR(697.2,LL,0),U)
- Q MDVAL
- CHKMED(MDCON) ; Check for Medicine results
- N MDCK,MDCX,MDY
- S MDY=0 D GETS^DIQ(123,MDCON_",","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["MCAR" S MDY=1
- Q MDY
- GETAMDT(MDCON) ; Check For Amendment
- N MDAMT,MDMS,MDX5,MDY S MDY=0
- S MDAMT="" F S MDAMT=$O(^MDD(702,"ACON",+MDCON,MDAMT),-1) Q:MDAMT<1!(+MDY) D
- .S MDMS=0 F S MDMS=$O(^MDD(702,MDAMT,.091,MDMS)) Q:MDMS<1!(+MDY) S MDX5=$G(^(MDMS,0)) I $P(MDX5,"^",9)["AMENDMENT" S MDY=+$P($G(^MDD(702,+MDAMT,0)),"^",6) Q
- Q MDY
- HDR ; Print Header for Report Form Feed
- N FFL,MDNM,MDNAME,MDTITL,MDTM S $P(FFL,"-",80)=""
- S MDNM=$QS(MDREC,4),MDNAME=$O(^MCAR(697.2,"B",MDNM,0))
- I MDNAME S MDTITL=$P($G(^MCAR(697.2,+MDNAME,0)),"^",8)
- I $G(MDTITL)="" S MDNAME=$O(^MDS(702.01,"B",MDNM,0)) S:MDNAME MDTITL=$P($G(^MDS(702.01,+MDNAME,0)),U)
- W !! D NOW^%DTC S X=% D DTIME^MCARP S MDTM=$$FMTE^XLFDT(X,2) K %
- S MDRPG=MDRPG+1 W !,"Pg. "_MDRPG_$J(" ",25)_$$HOSP^MDPS2(DFN)_$J(" ",25)_MDTM
- I $G(MDTITL)'="" W !,$J(" ",25)_MDTITL
- W !,$$DEMO^MDPS2(DFN)
- W !,FFL
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMDPS3 3648 printed Feb 18, 2025@23:10:17 Page 2
- MDPS3 ; HOIFO/NCA - Remote Data View Data Retriever for CP ;8/26/05 14:37
- +1 ;;1.0;CLINICAL PROCEDURES;**2,5,13,24**;Apr 01, 2004;Build 8
- +2 ; Integration Agreements:
- +3 ; Reference IA# 2693 [Subscription] TIU Extractions.
- +4 ; 3067 [Private] Read fields in Consult file (#123) w/FM
- +5 ; 10104 [Supported] Routine XLFSTR calls.
- +6 ; 875 [Subscription] Access Order Status file (#100.01)
- +7 ;
- GET702(MDGLO,MDDFN,MDC,MDSDT,MDEDT,MDMAX) ; Gather the new 702 entries
- +1 NEW MDARR,MDCON,MDDTE,MDLP,MDCODE,MDCTRR,MDPROC,MDSTAT,MDX
- +2 DO GP^MDPS5(MDDFN,MDSDT,MDEDT)
- SET MDCTRR=0
- +3 SET MDLP=""
- FOR
- SET MDLP=$ORDER(^MDD(702,"B",MDDFN,MDLP),-1)
- if MDLP<1
- QUIT
- Begin DoDot:1
- +4 SET MDX=$GET(^MDD(702,MDLP,0))
- if $PIECE(MDX,"^",9)'=3
- QUIT
- +5 SET MDPROC=$$GET1^DIQ(702,MDLP_",",.04,"E")
- if MDPROC=""
- QUIT
- +6 if '$PIECE(MDX,U,6)
- QUIT
- +7 KILL ^TMP("MDTIUST",$JOB)
- SET MDTIUER=""
- +8 DO EXTRACT^TIULQ($PIECE(MDX,U,6),"^TMP(""MDTIUST"",$J)",MDTIUER,".01;.05;70201;70202")
- if +MDTIUER
- QUIT
- +9 SET MDCODE=$GET(^TMP("MDTIUST",$JOB,$PIECE(MDX,U,6),70201,"E"))
- +10 if MDCODE'=""
- SET MDCODE=$$UP^XLFSTR(MDCODE)
- +11 IF $GET(MDC)'=""
- if MDCODE'=$GET(MDC)
- QUIT
- +12 SET MDDTE=$GET(^TMP("MDTIUST",$JOB,$PIECE(MDX,U,6),70202,"I"))
- +13 SET MDSTAT=$GET(^TMP("MDTIUST",$JOB,$PIECE(MDX,U,6),.05,"E"))
- +14 if 'MDDTE
- SET MDDTE=$$GET1^DIQ(702,MDLP_",",.02,"I")
- +15 KILL ^TMP("MDTIUST",$JOB)
- +16 SET MDCON=$PIECE(MDX,U,5)
- +17 IF +$GET(MDMAX)
- if MDCTRR=MDMAX
- QUIT
- +18 IF +$GET(MDSDT)
- if MDDTE<+$GET(MDSDT)
- QUIT
- +19 IF +$GET(MDEDT)
- if MDDTE>+$GET(MDEDT)
- QUIT
- +20 IF MDCON
- Begin DoDot:2
- +21 SET MDSTAT=$$GET1^DIQ(123,MDCON_",",8,"E")
- +22 IF MDSTAT=""
- SET MDSTAT=$$GET1^DIQ(123,MDCON_",",8,"I")
- if +MDSTAT
- SET MDSTAT=$$GET1^DIQ(100.01,MDSTAT_",",.01,"E")
- +23 QUIT
- End DoDot:2
- if MDSTAT'="COMPLETE"&(MDSTAT'="PARTIAL RESULTS")
- QUIT
- +24 SET Y=MDDTE
- XECUTE ^DD("DD")
- NEW MDREV
- SET MDREV=(9999999.9999-MDDTE)
- +25 IF MDCON
- if $GET(MDARR(MDCON))'=""
- QUIT
- SET MDARR(MDCON)=MDCON
- +26 if $GET(^TMP("MDPLST",$JOB,MDPROC,MDREV_"~"_MDLP))=""
- SET ^(MDREV_"~"_MDLP)=MDPROC_"^"_MDLP_"^"_"PR702"_"^"_"MDPS1"_"^^"_Y_"^"_MDCODE_"^^^^"_MDPROC_"^^"_MDCON_"^"_+$PIECE(MDX,U,6)
- +27 SET MDCTRR=MDCTRR+1
- +28 QUIT
- End DoDot:1
- +29 KILL MDARR
- +30 QUIT
- PRO(RESULT) ; Function to return info on single procedure.
- +1 ;
- +2 ; RESULT = variable pointer to a medicine file
- +3 ; (e.g. "12;MCAR(691.5,") (required)
- +4 NEW MDVAL,LL,S3,S4,S5
- +5 SET S3=+RESULT
- SET S4=$PIECE(RESULT,";",2)
- SET S4=$PIECE(S4,",")
- +6 IF S4="MCAR(702.7"
- QUIT ""
- +7 IF S4="MCAR(699"
- SET LL=$PIECE($GET(^MCAR(699,+S3,0)),U,12)
- SET MDVAL=$PIECE($GET(^MCAR(697.2,+LL,0)),U)
- QUIT MDVAL
- +8 IF S4="MCAR(699.5"
- SET LL=$PIECE($GET(^MCAR(699.5,+S3,0)),U,6)
- SET MDVAL=$PIECE($GET(^MCAR(697.2,+LL,0)),U)
- QUIT MDVAL
- +9 IF S4="MCAR(694"
- SET LL=$PIECE($GET(^MCAR(699.5,+S3,0)),U,6)
- SET MDVAL=$PIECE($GET(^MCAR(697.2,+LL,0)),U)
- QUIT MDVAL
- +10 SET LL=$ORDER(^MCAR(697.2,"C",S4,0))
- SET MDVAL=$PIECE(^MCAR(697.2,LL,0),U)
- +11 QUIT MDVAL
- CHKMED(MDCON) ; Check for Medicine results
- +1 NEW MDCK,MDCX,MDY
- +2 SET MDY=0
- DO GETS^DIQ(123,MDCON_",","50*","I","MDCX")
- +3 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:1
- +4 IF MDX4["MCAR"
- SET MDY=1
- End DoDot:1
- +5 QUIT MDY
- GETAMDT(MDCON) ; Check For Amendment
- +1 NEW MDAMT,MDMS,MDX5,MDY
- SET MDY=0
- +2 SET MDAMT=""
- FOR
- SET MDAMT=$ORDER(^MDD(702,"ACON",+MDCON,MDAMT),-1)
- if MDAMT<1!(+MDY)
- QUIT
- Begin DoDot:1
- +3 SET MDMS=0
- FOR
- SET MDMS=$ORDER(^MDD(702,MDAMT,.091,MDMS))
- if MDMS<1!(+MDY)
- QUIT
- SET MDX5=$GET(^(MDMS,0))
- IF $PIECE(MDX5,"^",9)["AMENDMENT"
- SET MDY=+$PIECE($GET(^MDD(702,+MDAMT,0)),"^",6)
- QUIT
- End DoDot:1
- +4 QUIT MDY
- HDR ; Print Header for Report Form Feed
- +1 NEW FFL,MDNM,MDNAME,MDTITL,MDTM
- SET $PIECE(FFL,"-",80)=""
- +2 SET MDNM=$QSUBSCRIPT(MDREC,4)
- SET MDNAME=$ORDER(^MCAR(697.2,"B",MDNM,0))
- +3 IF MDNAME
- SET MDTITL=$PIECE($GET(^MCAR(697.2,+MDNAME,0)),"^",8)
- +4 IF $GET(MDTITL)=""
- SET MDNAME=$ORDER(^MDS(702.01,"B",MDNM,0))
- if MDNAME
- SET MDTITL=$PIECE($GET(^MDS(702.01,+MDNAME,0)),U)
- +5 WRITE !!
- DO NOW^%DTC
- SET X=%
- DO DTIME^MCARP
- SET MDTM=$$FMTE^XLFDT(X,2)
- KILL %
- +6 SET MDRPG=MDRPG+1
- WRITE !,"Pg. "_MDRPG_$JUSTIFY(" ",25)_$$HOSP^MDPS2(DFN)_$JUSTIFY(" ",25)_MDTM
- +7 IF $GET(MDTITL)'=""
- WRITE !,$JUSTIFY(" ",25)_MDTITL
- +8 WRITE !,$$DEMO^MDPS2(DFN)
- +9 WRITE !,FFL
- +10 QUIT