- GMRCXR ; ALB/SAT - GMR DD UTILITY ; May 25, 2023@10:25:35
- ;;3.0;CONSULT/REQUEST TRACKING;**83,86,169,189**;Dec 27, 1997;Build 54
- ;DD support for VISTA SCHEDULING ENHANCEMENT SD*5.3*627
- ;New x-ref utility for GMRC*3*169
- ;Reference is made to ICR #6184
- ;
- Q
- AG123S1(GMRCDA1,GMRCDR) ;build AG xref ;called by 'Set Logic' and 'Kill Logic' of the New Style AG cross reference #336 in file 123
- ;GMRCDA1 = DA(1) IEN pointer to REQUEST/CONSULTATION file 123
- ;GMRCDR = DATE OF REQUEST in FM format from field 3 of top level of file 123
- N CHK
- S GMRCDA1=$G(GMRCDA1) Q:'+GMRCDA1
- S GMRCDR=$G(GMRCDR,0) S:'GMRCDR GMRCDR=$P($G(^GMR(123,GMRCDA1,0)),U,7) ;alb/sat 86 setup GMRCDR if not passed in
- Q:GMRCDR="" ;alb/sat 86 do not include if DATE OF REQUEST is not defined
- S CHK=$$REQCHK(GMRCDA1)
- S:(CHK=0)&(GMRCDR'="") ^GMR(123,"AG",GMRCDR,GMRCDA1)=""
- K:(+CHK)&(GMRCDR'="") ^GMR(123,"AG",GMRCDR,GMRCDA1)
- Q
- ;
- REQCHK(GMRCID) ;check activities to determine if the REQUEST/CONSULTATION entry is still active and not scheduled
- N GMRCCAN,GMRCCANF,GMRCDC,GMRCDONE,GMRCES,GMRCESF,GMRCNOD,GMRCPDC,GMRC40,GMRCACT,GMRCRPA,GMRCSCH,GMRCSCHF,GMRCSER,GMRCST,GMRCSTF
- N GMRCCS,GMRCFD,GMRCPA
- N GMRCNOS,X,X1,X2 ;alb/sat 86
- S GMRCPA=$O(^ORD(100.01,"B","ACTIVE",0))
- S GMRCPDC=$O(^ORD(100.01,"B","DISCONTINUED",0))
- S GMRCCS=$$GET1^DIQ(123,GMRCID_",",8,"I")
- Q:GMRCCS=GMRCPDC 1 ;don't return this entry if CPRS STATUS is DISCONTINUED
- ;Q:$$GET1^DIQ(123,GMRCID_",",8,"I")=GMRCPDC 1 ;don't include this entry if CPRS STATUS is DISCONTINUED ;alb/sat 86 removed redundant check
- S GMRCFD=$P($$GET1^DIQ(123,GMRCID_",",.01,"I"),".",1) ;alb/sat 86 - get FILE ENTRY DATE
- Q:$$FMADD^XLFDT(DT,-365)>GMRCFD 1 ;alb/sat 86 - do not include records with FILE ENTRY DATE older than 1 year
- S GMRCSCH=$$GETIEN("SCHEDULED")
- S GMRCST=$$GETIEN("STATUS CHANGE")
- S GMRCCAN=$$GETIEN("CANCELLED")
- S GMRCDONE=$$GETIEN("COMPLETE/UPDATE")
- S GMRCDC=$$GETIEN("DISCONTINUED")
- S GMRCES=$$GETIEN("EDIT/RESUBMITTED")
- S GMRCNOD=$G(^GMR(123,GMRCID,0))
- S GMRCSER=$P(GMRCNOD,U,5)
- S DFN=$P(GMRCNOD,U,2)
- S (GMRCCANF,GMRCESF,GMRCSCHF,GMRCSTF)=0
- ;alb/sat 86 - start modification
- I GMRCCS=13 D G REQCHKX ;cancel/no-show ;13 is cancel - see A+7^SDCNSLT SD*5.3*627
- .S GMRCCANF=1
- .S GMRCNOS=$O(^GMR(123,GMRCID,40,":"),-1) Q:'+GMRCNOS ;ICR 6185
- .S GMRCNOS=$O(^GMR(123,GMRCID,40,GMRCNOS),-1) Q:'+GMRCNOS
- .S X2=$P($G(^GMR(123,GMRCID,40,GMRCNOS,0)),U),X1=DT D ^%DTC Q:X'=""&(X>180) ;ICR 6185
- .I $$FINDTXT(GMRCID,GMRCNOS) D
- ..S GMRCCANF=0
- ;alb/sat 86 - end modification
- ;GMRCESF - if 1 we have determined this request should be returned (return 0)
- S GMRCRPA=9999999 F S GMRCRPA=$O(^GMR(123,GMRCID,40,GMRCRPA),-1) Q:GMRCRPA'>0 D Q:GMRCCANF=1 Q:GMRCSCHF=1 Q:GMRCESF=1
- .S GMRC40=$G(^GMR(123,GMRCID,40,GMRCRPA,0))
- .S GMRCACT=$P(GMRC40,U,2) ;ACTIVITY field 1
- .I GMRCACT'=GMRCSCH,GMRCACT'=GMRCST,GMRCACT'=GMRCCAN,GMRCACT'=GMRCDONE,GMRCACT'=GMRCDC,GMRCACT'=GMRCES Q ;only watch the ones we need
- .I GMRCACT=GMRCCAN!(GMRCACT=GMRCDONE)!(GMRCACT=GMRCDC) S GMRCCANF=1 Q ;skip completed consults/mgh
- .I GMRCACT=GMRCES S GMRCESF=1 Q
- .I GMRCACT=GMRCSCH,GMRCSTF=1 S GMRCESF=1 Q
- .I GMRCACT=GMRCSCH,GMRCSTF'=1,$$SCHED(DFN,$P(GMRC40,U,3),GMRCSER) S GMRCSCHF=1 Q
- .;I GMRCACT=GMRCST,$$FINDTXT(GMRCID,GMRCRPA) S GMRCSTF=1
- .I GMRCACT=GMRCST,GMRCCS=GMRCPA S GMRCSTF=1
- REQCHKX ; exit ;alb/sat 86 - add REQCHKX tag
- Q:GMRCSCHF GMRCSCHF
- Q:GMRCCANF GMRCCANF
- Q:GMRCESF 0
- Q 0
- ;
- GETIEN(GMRCNM) ;get ID from REQUEST ACTION TYPES file 123.1
- N Y
- S Y=$O(^GMR(123.1,"B",GMRCNM,0))
- Q Y
- ;
- SCHED(DFN,GMRCDT,GMRCSVC) ;look for appointment with stop code matching one in REQUEST SERVICES
- ;INPUT:
- ; DFN - patient ID pointer to PATIENT file
- ; GMRCDT - actual activity date in FM format
- ; GMRCSVC - request services ID pointer to REQUEST SERVICES file 123.5
- ;RETURN:
- ; 0 = no appointment found with matching stop code
- ; 1 = appointment found with matching stop code
- ;Q 1 ;do not check for match for now
- N GMRCAPI,GMRCARR,GMRCI,GMRCJ,GMRCRET,GMRCSTP,GMRCSTPL
- S GMRCRET=0
- S GMRCSVC=$G(GMRCSVC)
- Q:GMRCSVC="" 0
- S GMRCDT=$P($G(GMRCDT),".",1)
- I GMRCDT'?7N S GMRCDT=1000103
- S GMRCI=0 F S GMRCI=$O(^GMR(123.5,GMRCSVC,688,GMRCI)) Q:GMRCI'>0 D
- .S GMRCSTPL(+$P($G(^GMR(123.5,GMRCSVC,688,GMRCI,0)),U,1))=""
- K ^TMP($J,"SDAMA301"),GMRCARR
- S GMRCARR(1)=$P($$FMADD^XLFDT(GMRCDT,-1),".",1)_";" ;go back 1 day and look forward for appt with matching stop code
- S GMRCARR(4)=DFN
- S GMRCARR("FLDS")="2;13"
- S GMRCAPI=$$SDAPI^SDAMA301(.GMRCARR)
- ;GMRCI - pointer to file 44; GMRCJ - appt date/time
- S GMRCI=0 F S GMRCI=$O(^TMP($J,"SDAMA301",DFN,GMRCI)) Q:GMRCI'>0 D Q:+GMRCRET
- .S GMRCJ=0 F S GMRCJ=$O(^TMP($J,"SDAMA301",DFN,GMRCI,GMRCJ)) Q:GMRCJ'>0 D Q:+GMRCRET
- ..S GMRCSTP=+$P($G(^TMP($J,"SDAMA301",DFN,GMRCI,GMRCJ)),U,13)
- ..I $P($G(^TMP($J,"SDAMA301",DFN,GMRCI,GMRCJ)),U,25)="",$D(GMRCSTPL(+GMRCSTP)) S GMRCRET=1 ;alb/sat 86
- ..;S:$D(GMRCSTPL(+GMRCSTP)) GMRCRET=1
- K ^TMP($J,"SDAMA301"),GMRCARR
- Q GMRCRET
- ;
- FINDTXT(GMRCID,GMRCRPA,GMRCTXT) ;find text in word processing field ;alb/sat 86 - removed unused 3rd parameter
- ;INPUT:
- ; GMRCID - Pointer to REQUEST/CONSULTATION file
- ; GMRCRPA - Pointer to REQUEST PROCESSING ACTIVITY in REQUEST/CONSULTATION file
- ;RETURN:
- ; 1=Text Fount; 0=Not Found
- ;alb/sat 86 begin modification
- N GMRCI,GMRCJ,GMRCLINE,GMRCMSG,GMRCPREV,GMRCRET,GMRCTHIS,GMRCWP,X
- S (GMRCTHIS,GMRCPREV)=""
- S GMRCRET=0
- S GMRCTXT=$G(GMRCTXT) S:GMRCTXT'="" GMRCTXT=$$UP^XLFSTR(GMRCTXT) ;alb/sat 86
- K GMRCWP S X=$$GET1^DIQ(123.02,GMRCRPA_","_GMRCID_",",5,"","GMRCWP","GMRCMSG") ;ICR 6185
- S GMRCI=0 F S GMRCI=$O(GMRCWP(GMRCI)) Q:GMRCI="" D Q:GMRCRET=1
- .S GMRCTHIS=GMRCWP(GMRCI)
- .S GMRCLINE=$$UP^XLFSTR(GMRCPREV_GMRCTHIS)
- .I GMRCTXT'="" S:GMRCLINE[GMRCTXT GMRCRET=1 Q
- .F GMRCJ=1:1 S GMRCTXT=$P($T(GMRCTXT+GMRCJ),";;",2) Q:GMRCTXT="" D Q:GMRCRET=1
- ..S:GMRCLINE[GMRCTXT GMRCRET=1
- .;alb/sat 86 end modification
- .S GMRCPREV=GMRCTHIS ;keep 'this' line for next iteration in case the phrase wraps around onto 2 lines
- Q GMRCRET
- ;
- ;alb/sat 86
- GMRCTXT ;
- ;;CANCEL
- ;;NOSHOW
- ;;NO-SHOW
- ;;NO SHOW
- ;
- ;
- POST ;post install for GMRC*3*86
- D XREF
- Q
- XREF ;create and build NEW style AG for all REQUEST/CONSULTATION entries in file 123
- N GMRCXR,GMRCRES,GMRCOUT
- S GMRCXR("FILE")=123
- S GMRCXR("NAME")="AG"
- S GMRCXR("SHORT DESCR")="Index of active REQUEST/CONSULTs with no appointment scheduled."
- S GMRCXR("TYPE")="M"
- S GMRCXR("EXECUTION")="F"
- S GMRCXR("ACTIVITY")="IR"
- S GMRCXR("ROOT TYPE")="W"
- S GMRCXR("ROOT FILE")=123.02
- S GMRCXR("USE")="S"
- S GMRCXR("DESCR",1)="This cross reference contains entries of the REQUEST/CONSULTATION file"
- S GMRCXR("DESCR",2)="that do not have an appointment scheduled."
- S GMRCXR("DESCR",3)="This is determined based on the content and order of the entries in"
- S GMRCXR("DESCR",4)="the REQUEST PROCESSING ACTIVITY multiple field 40. This cross"
- S GMRCXR("DESCR",5)="reference will be updated with any update to the ACTIVITY field under"
- S GMRCXR("DESCR",6)="the REQUEST PROCESSING ACTIVITY multiple and that update will be"
- S GMRCXR("DESCR",7)="determined based on all REQUEST PROCESSING ACTIVITY entries."
- S GMRCXR("DESCR",8)="This cross reference was added in GMRC*3.0*83."
- S GMRCXR("SET")="D AG123S1^GMRCXR(DA(1),X)"
- S GMRCXR("KILL")="D AG123S1^GMRCXR(DA(1),X)"
- S GMRCXR("WHOLE KILL")="K ^GMR(123,""AG"")"
- S GMRCXR("VAL",1)="S X=+$P($G(^GMR(123,DA(1),0)),U,7)"
- S GMRCXR("VAL",1,"TYP")="C"
- S GMRCXR("VAL",1,"SUBSCRIPT")=1
- S GMRCXR("VAL",1,"COLLATION")="F"
- D CREIXN^DDMOD(.GMRCXR,"S",.GMRCRES,"GMRCOUT")
- Q
- ;
- ;
- POST169 ;post install for GMRC*3*169
- D AIFC
- Q
- AIFC ;create and build NEW style AIFC for all REQUEST/CONSULTATION entries in file 123
- ;;Built with DIKCBLD
- N GMRCXR,GMRCRES,GMRCOUT
- S GMRCXR("FILE")=123
- S GMRCXR("NAME")="AIFC"
- S GMRCXR("TYPE")="R"
- S GMRCXR("USE")="S"
- S GMRCXR("DESCR",1)="This cross reference is used to look up IFC, process actions on IFC, and process IFC HL7."
- S GMRCXR("EXECUTION")="R"
- S GMRCXR("ACTIVITY")="IR"
- S GMRCXR("SHORT DESCR")="Index on ROUTING FACILITY & REMOTE CONSULT #"
- S GMRCXR("VAL",1)=.07
- S GMRCXR("VAL",1,"SUBSCRIPT")=1
- S GMRCXR("VAL",1,"LENGTH")=5
- S GMRCXR("VAL",1,"COLLATION")="F"
- S GMRCXR("VAL",2)=.06
- S GMRCXR("VAL",2,"SUBSCRIPT")=2
- S GMRCXR("VAL",2,"LENGTH")=20 ;modified to correct field length - was 9 ; changed 12 to 20 *189 wtc 5/25/2023
- S GMRCXR("VAL",2,"COLLATION")="F"
- D CREIXN^DDMOD(.GMRCXR,"SW",.GMRCRES,"GMRCOUT")
- Q
- ;
- POST189 ; post=install for GMRC*3*189
- D AIFC Q ;
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCXR 8727 printed Feb 18, 2025@23:14:10 Page 2
- GMRCXR ; ALB/SAT - GMR DD UTILITY ; May 25, 2023@10:25:35
- +1 ;;3.0;CONSULT/REQUEST TRACKING;**83,86,169,189**;Dec 27, 1997;Build 54
- +2 ;DD support for VISTA SCHEDULING ENHANCEMENT SD*5.3*627
- +3 ;New x-ref utility for GMRC*3*169
- +4 ;Reference is made to ICR #6184
- +5 ;
- +6 QUIT
- AG123S1(GMRCDA1,GMRCDR) ;build AG xref ;called by 'Set Logic' and 'Kill Logic' of the New Style AG cross reference #336 in file 123
- +1 ;GMRCDA1 = DA(1) IEN pointer to REQUEST/CONSULTATION file 123
- +2 ;GMRCDR = DATE OF REQUEST in FM format from field 3 of top level of file 123
- +3 NEW CHK
- +4 SET GMRCDA1=$GET(GMRCDA1)
- if '+GMRCDA1
- QUIT
- +5 ;alb/sat 86 setup GMRCDR if not passed in
- SET GMRCDR=$GET(GMRCDR,0)
- if 'GMRCDR
- SET GMRCDR=$PIECE($GET(^GMR(123,GMRCDA1,0)),U,7)
- +6 ;alb/sat 86 do not include if DATE OF REQUEST is not defined
- if GMRCDR=""
- QUIT
- +7 SET CHK=$$REQCHK(GMRCDA1)
- +8 if (CHK=0)&(GMRCDR'="")
- SET ^GMR(123,"AG",GMRCDR,GMRCDA1)=""
- +9 if (+CHK)&(GMRCDR'="")
- KILL ^GMR(123,"AG",GMRCDR,GMRCDA1)
- +10 QUIT
- +11 ;
- REQCHK(GMRCID) ;check activities to determine if the REQUEST/CONSULTATION entry is still active and not scheduled
- +1 NEW GMRCCAN,GMRCCANF,GMRCDC,GMRCDONE,GMRCES,GMRCESF,GMRCNOD,GMRCPDC,GMRC40,GMRCACT,GMRCRPA,GMRCSCH,GMRCSCHF,GMRCSER,GMRCST,GMRCSTF
- +2 NEW GMRCCS,GMRCFD,GMRCPA
- +3 ;alb/sat 86
- NEW GMRCNOS,X,X1,X2
- +4 SET GMRCPA=$ORDER(^ORD(100.01,"B","ACTIVE",0))
- +5 SET GMRCPDC=$ORDER(^ORD(100.01,"B","DISCONTINUED",0))
- +6 SET GMRCCS=$$GET1^DIQ(123,GMRCID_",",8,"I")
- +7 ;don't return this entry if CPRS STATUS is DISCONTINUED
- if GMRCCS=GMRCPDC
- QUIT 1
- +8 ;Q:$$GET1^DIQ(123,GMRCID_",",8,"I")=GMRCPDC 1 ;don't include this entry if CPRS STATUS is DISCONTINUED ;alb/sat 86 removed redundant check
- +9 ;alb/sat 86 - get FILE ENTRY DATE
- SET GMRCFD=$PIECE($$GET1^DIQ(123,GMRCID_",",.01,"I"),".",1)
- +10 ;alb/sat 86 - do not include records with FILE ENTRY DATE older than 1 year
- if $$FMADD^XLFDT(DT,-365)>GMRCFD
- QUIT 1
- +11 SET GMRCSCH=$$GETIEN("SCHEDULED")
- +12 SET GMRCST=$$GETIEN("STATUS CHANGE")
- +13 SET GMRCCAN=$$GETIEN("CANCELLED")
- +14 SET GMRCDONE=$$GETIEN("COMPLETE/UPDATE")
- +15 SET GMRCDC=$$GETIEN("DISCONTINUED")
- +16 SET GMRCES=$$GETIEN("EDIT/RESUBMITTED")
- +17 SET GMRCNOD=$GET(^GMR(123,GMRCID,0))
- +18 SET GMRCSER=$PIECE(GMRCNOD,U,5)
- +19 SET DFN=$PIECE(GMRCNOD,U,2)
- +20 SET (GMRCCANF,GMRCESF,GMRCSCHF,GMRCSTF)=0
- +21 ;alb/sat 86 - start modification
- +22 ;cancel/no-show ;13 is cancel - see A+7^SDCNSLT SD*5.3*627
- IF GMRCCS=13
- Begin DoDot:1
- +23 SET GMRCCANF=1
- +24 ;ICR 6185
- SET GMRCNOS=$ORDER(^GMR(123,GMRCID,40,":"),-1)
- if '+GMRCNOS
- QUIT
- +25 SET GMRCNOS=$ORDER(^GMR(123,GMRCID,40,GMRCNOS),-1)
- if '+GMRCNOS
- QUIT
- +26 ;ICR 6185
- SET X2=$PIECE($GET(^GMR(123,GMRCID,40,GMRCNOS,0)),U)
- SET X1=DT
- DO ^%DTC
- if X'=""&(X>180)
- QUIT
- +27 IF $$FINDTXT(GMRCID,GMRCNOS)
- Begin DoDot:2
- +28 SET GMRCCANF=0
- End DoDot:2
- End DoDot:1
- GOTO REQCHKX
- +29 ;alb/sat 86 - end modification
- +30 ;GMRCESF - if 1 we have determined this request should be returned (return 0)
- +31 SET GMRCRPA=9999999
- FOR
- SET GMRCRPA=$ORDER(^GMR(123,GMRCID,40,GMRCRPA),-1)
- if GMRCRPA'>0
- QUIT
- Begin DoDot:1
- +32 SET GMRC40=$GET(^GMR(123,GMRCID,40,GMRCRPA,0))
- +33 ;ACTIVITY field 1
- SET GMRCACT=$PIECE(GMRC40,U,2)
- +34 ;only watch the ones we need
- IF GMRCACT'=GMRCSCH
- IF GMRCACT'=GMRCST
- IF GMRCACT'=GMRCCAN
- IF GMRCACT'=GMRCDONE
- IF GMRCACT'=GMRCDC
- IF GMRCACT'=GMRCES
- QUIT
- +35 ;skip completed consults/mgh
- IF GMRCACT=GMRCCAN!(GMRCACT=GMRCDONE)!(GMRCACT=GMRCDC)
- SET GMRCCANF=1
- QUIT
- +36 IF GMRCACT=GMRCES
- SET GMRCESF=1
- QUIT
- +37 IF GMRCACT=GMRCSCH
- IF GMRCSTF=1
- SET GMRCESF=1
- QUIT
- +38 IF GMRCACT=GMRCSCH
- IF GMRCSTF'=1
- IF $$SCHED(DFN,$PIECE(GMRC40,U,3),GMRCSER)
- SET GMRCSCHF=1
- QUIT
- +39 ;I GMRCACT=GMRCST,$$FINDTXT(GMRCID,GMRCRPA) S GMRCSTF=1
- +40 IF GMRCACT=GMRCST
- IF GMRCCS=GMRCPA
- SET GMRCSTF=1
- End DoDot:1
- if GMRCCANF=1
- QUIT
- if GMRCSCHF=1
- QUIT
- if GMRCESF=1
- QUIT
- REQCHKX ; exit ;alb/sat 86 - add REQCHKX tag
- +1 if GMRCSCHF
- QUIT GMRCSCHF
- +2 if GMRCCANF
- QUIT GMRCCANF
- +3 if GMRCESF
- QUIT 0
- +4 QUIT 0
- +5 ;
- GETIEN(GMRCNM) ;get ID from REQUEST ACTION TYPES file 123.1
- +1 NEW Y
- +2 SET Y=$ORDER(^GMR(123.1,"B",GMRCNM,0))
- +3 QUIT Y
- +4 ;
- SCHED(DFN,GMRCDT,GMRCSVC) ;look for appointment with stop code matching one in REQUEST SERVICES
- +1 ;INPUT:
- +2 ; DFN - patient ID pointer to PATIENT file
- +3 ; GMRCDT - actual activity date in FM format
- +4 ; GMRCSVC - request services ID pointer to REQUEST SERVICES file 123.5
- +5 ;RETURN:
- +6 ; 0 = no appointment found with matching stop code
- +7 ; 1 = appointment found with matching stop code
- +8 ;Q 1 ;do not check for match for now
- +9 NEW GMRCAPI,GMRCARR,GMRCI,GMRCJ,GMRCRET,GMRCSTP,GMRCSTPL
- +10 SET GMRCRET=0
- +11 SET GMRCSVC=$GET(GMRCSVC)
- +12 if GMRCSVC=""
- QUIT 0
- +13 SET GMRCDT=$PIECE($GET(GMRCDT),".",1)
- +14 IF GMRCDT'?7N
- SET GMRCDT=1000103
- +15 SET GMRCI=0
- FOR
- SET GMRCI=$ORDER(^GMR(123.5,GMRCSVC,688,GMRCI))
- if GMRCI'>0
- QUIT
- Begin DoDot:1
- +16 SET GMRCSTPL(+$PIECE($GET(^GMR(123.5,GMRCSVC,688,GMRCI,0)),U,1))=""
- End DoDot:1
- +17 KILL ^TMP($JOB,"SDAMA301"),GMRCARR
- +18 ;go back 1 day and look forward for appt with matching stop code
- SET GMRCARR(1)=$PIECE($$FMADD^XLFDT(GMRCDT,-1),".",1)_";"
- +19 SET GMRCARR(4)=DFN
- +20 SET GMRCARR("FLDS")="2;13"
- +21 SET GMRCAPI=$$SDAPI^SDAMA301(.GMRCARR)
- +22 ;GMRCI - pointer to file 44; GMRCJ - appt date/time
- +23 SET GMRCI=0
- FOR
- SET GMRCI=$ORDER(^TMP($JOB,"SDAMA301",DFN,GMRCI))
- if GMRCI'>0
- QUIT
- Begin DoDot:1
- +24 SET GMRCJ=0
- FOR
- SET GMRCJ=$ORDER(^TMP($JOB,"SDAMA301",DFN,GMRCI,GMRCJ))
- if GMRCJ'>0
- QUIT
- Begin DoDot:2
- +25 SET GMRCSTP=+$PIECE($GET(^TMP($JOB,"SDAMA301",DFN,GMRCI,GMRCJ)),U,13)
- +26 ;alb/sat 86
- IF $PIECE($GET(^TMP($JOB,"SDAMA301",DFN,GMRCI,GMRCJ)),U,25)=""
- IF $DATA(GMRCSTPL(+GMRCSTP))
- SET GMRCRET=1
- +27 ;S:$D(GMRCSTPL(+GMRCSTP)) GMRCRET=1
- End DoDot:2
- if +GMRCRET
- QUIT
- End DoDot:1
- if +GMRCRET
- QUIT
- +28 KILL ^TMP($JOB,"SDAMA301"),GMRCARR
- +29 QUIT GMRCRET
- +30 ;
- FINDTXT(GMRCID,GMRCRPA,GMRCTXT) ;find text in word processing field ;alb/sat 86 - removed unused 3rd parameter
- +1 ;INPUT:
- +2 ; GMRCID - Pointer to REQUEST/CONSULTATION file
- +3 ; GMRCRPA - Pointer to REQUEST PROCESSING ACTIVITY in REQUEST/CONSULTATION file
- +4 ;RETURN:
- +5 ; 1=Text Fount; 0=Not Found
- +6 ;alb/sat 86 begin modification
- +7 NEW GMRCI,GMRCJ,GMRCLINE,GMRCMSG,GMRCPREV,GMRCRET,GMRCTHIS,GMRCWP,X
- +8 SET (GMRCTHIS,GMRCPREV)=""
- +9 SET GMRCRET=0
- +10 ;alb/sat 86
- SET GMRCTXT=$GET(GMRCTXT)
- if GMRCTXT'=""
- SET GMRCTXT=$$UP^XLFSTR(GMRCTXT)
- +11 ;ICR 6185
- KILL GMRCWP
- SET X=$$GET1^DIQ(123.02,GMRCRPA_","_GMRCID_",",5,"","GMRCWP","GMRCMSG")
- +12 SET GMRCI=0
- FOR
- SET GMRCI=$ORDER(GMRCWP(GMRCI))
- if GMRCI=""
- QUIT
- Begin DoDot:1
- +13 SET GMRCTHIS=GMRCWP(GMRCI)
- +14 SET GMRCLINE=$$UP^XLFSTR(GMRCPREV_GMRCTHIS)
- +15 IF GMRCTXT'=""
- if GMRCLINE[GMRCTXT
- SET GMRCRET=1
- QUIT
- +16 FOR GMRCJ=1:1
- SET GMRCTXT=$PIECE($TEXT(GMRCTXT+GMRCJ),";;",2)
- if GMRCTXT=""
- QUIT
- Begin DoDot:2
- +17 if GMRCLINE[GMRCTXT
- SET GMRCRET=1
- End DoDot:2
- if GMRCRET=1
- QUIT
- +18 ;alb/sat 86 end modification
- +19 ;keep 'this' line for next iteration in case the phrase wraps around onto 2 lines
- SET GMRCPREV=GMRCTHIS
- End DoDot:1
- if GMRCRET=1
- QUIT
- +20 QUIT GMRCRET
- +21 ;
- +22 ;alb/sat 86
- GMRCTXT ;
- +1 ;;CANCEL
- +2 ;;NOSHOW
- +3 ;;NO-SHOW
- +4 ;;NO SHOW
- +5 ;
- +6 ;
- POST ;post install for GMRC*3*86
- +1 DO XREF
- +2 QUIT
- XREF ;create and build NEW style AG for all REQUEST/CONSULTATION entries in file 123
- +1 NEW GMRCXR,GMRCRES,GMRCOUT
- +2 SET GMRCXR("FILE")=123
- +3 SET GMRCXR("NAME")="AG"
- +4 SET GMRCXR("SHORT DESCR")="Index of active REQUEST/CONSULTs with no appointment scheduled."
- +5 SET GMRCXR("TYPE")="M"
- +6 SET GMRCXR("EXECUTION")="F"
- +7 SET GMRCXR("ACTIVITY")="IR"
- +8 SET GMRCXR("ROOT TYPE")="W"
- +9 SET GMRCXR("ROOT FILE")=123.02
- +10 SET GMRCXR("USE")="S"
- +11 SET GMRCXR("DESCR",1)="This cross reference contains entries of the REQUEST/CONSULTATION file"
- +12 SET GMRCXR("DESCR",2)="that do not have an appointment scheduled."
- +13 SET GMRCXR("DESCR",3)="This is determined based on the content and order of the entries in"
- +14 SET GMRCXR("DESCR",4)="the REQUEST PROCESSING ACTIVITY multiple field 40. This cross"
- +15 SET GMRCXR("DESCR",5)="reference will be updated with any update to the ACTIVITY field under"
- +16 SET GMRCXR("DESCR",6)="the REQUEST PROCESSING ACTIVITY multiple and that update will be"
- +17 SET GMRCXR("DESCR",7)="determined based on all REQUEST PROCESSING ACTIVITY entries."
- +18 SET GMRCXR("DESCR",8)="This cross reference was added in GMRC*3.0*83."
- +19 SET GMRCXR("SET")="D AG123S1^GMRCXR(DA(1),X)"
- +20 SET GMRCXR("KILL")="D AG123S1^GMRCXR(DA(1),X)"
- +21 SET GMRCXR("WHOLE KILL")="K ^GMR(123,""AG"")"
- +22 SET GMRCXR("VAL",1)="S X=+$P($G(^GMR(123,DA(1),0)),U,7)"
- +23 SET GMRCXR("VAL",1,"TYP")="C"
- +24 SET GMRCXR("VAL",1,"SUBSCRIPT")=1
- +25 SET GMRCXR("VAL",1,"COLLATION")="F"
- +26 DO CREIXN^DDMOD(.GMRCXR,"S",.GMRCRES,"GMRCOUT")
- +27 QUIT
- +28 ;
- +29 ;
- POST169 ;post install for GMRC*3*169
- +1 DO AIFC
- +2 QUIT
- AIFC ;create and build NEW style AIFC for all REQUEST/CONSULTATION entries in file 123
- +1 ;;Built with DIKCBLD
- +2 NEW GMRCXR,GMRCRES,GMRCOUT
- +3 SET GMRCXR("FILE")=123
- +4 SET GMRCXR("NAME")="AIFC"
- +5 SET GMRCXR("TYPE")="R"
- +6 SET GMRCXR("USE")="S"
- +7 SET GMRCXR("DESCR",1)="This cross reference is used to look up IFC, process actions on IFC, and process IFC HL7."
- +8 SET GMRCXR("EXECUTION")="R"
- +9 SET GMRCXR("ACTIVITY")="IR"
- +10 SET GMRCXR("SHORT DESCR")="Index on ROUTING FACILITY & REMOTE CONSULT #"
- +11 SET GMRCXR("VAL",1)=.07
- +12 SET GMRCXR("VAL",1,"SUBSCRIPT")=1
- +13 SET GMRCXR("VAL",1,"LENGTH")=5
- +14 SET GMRCXR("VAL",1,"COLLATION")="F"
- +15 SET GMRCXR("VAL",2)=.06
- +16 SET GMRCXR("VAL",2,"SUBSCRIPT")=2
- +17 ;modified to correct field length - was 9 ; changed 12 to 20 *189 wtc 5/25/2023
- SET GMRCXR("VAL",2,"LENGTH")=20
- +18 SET GMRCXR("VAL",2,"COLLATION")="F"
- +19 DO CREIXN^DDMOD(.GMRCXR,"SW",.GMRCRES,"GMRCOUT")
- +20 QUIT
- +21 ;
- POST189 ; post=install for GMRC*3*189
- +1 ;
- DO AIFC
- QUIT
- +2 ;