PXRMGECU ;SLC/AGP,JVS - CLINICAL REMINDERS ;Oct 17, 2022@10:07:20
;;2.0;CLINICAL REMINDERS;**4,83**;Feb 04, 2005;Build 14
Q
FINISHED(DFN,ANS) ;Delete 801.5 entries if finished
;ANS=Answer to YES/NO button should be 1 or will quit
Q:DFN=""
Q:ANS=0
S PATDA="" F S PATDA=$O(^PXRMD(801.5,"B",DFN,PATDA)) Q:PATDA="" D
.S DA=PATDA,DIK="^PXRMD(801.5," D ^DIK
K DA,DIK,PATDA
Q
;
CON(IEN,DFN) ;CHECK TO see if 2 DIA ARE DONE to display consult
N OK
;
S OK=0
S GEC1DA=$O(^PXRMD(801.41,"AC","GEC1",0))
S GEC2DA=$O(^PXRMD(801.41,"AC","GEC2",0))
S GEC3DA=$O(^PXRMD(801.41,"AC","GEC3",0))
S GECFDA=$O(^PXRMD(801.41,"AC","GECF",0))
Q:IEN'=GEC1DA!(IEN'=GEC2DA)!(IEN'=GEC3DA) OK
;
S CNT=0
I $D(^PXRMD(801.5,"AD",DFN,"GEC1")) S CNT=CNT+1
I $D(^PXRMD(801.5,"AD",DFN,"GEC2")) S CNT=CNT+1
I $D(^PXRMD(801.5,"AD",DFN,"GEC3")) S CNT=CNT+1
;
I CNT>1 S OK=1
Q OK
;
DEL(NOTEIEN) ;Delete HF and 801.5 Called from DELETE^TIUEDI1
N DFN,TIUNODE,FILEIEN,GEC,ENCDT,GECNODE,GECT,GECDA,HFDA
N HFARY
Q:'$D(^PXRMD(801.5,"ACOPY",NOTEIEN))
S DFN=$O(^PXRMD(801.5,"ACOPY",NOTEIEN,0))
S ENCDT=$O(^PXRMD(801.5,"ACOPY",NOTEIEN,DFN,0))
I $D(^PXRMD(801.5,"ANOTE",NOTEIEN)) D
.S GEC="" F S GEC=$O(^PXRMD(801.5,"ANOTE",NOTEIEN,GEC)) Q:GEC="" D
..S FILEIEN=0 F S FILEIEN=$O(^PXRMD(801.5,"ANOTE",NOTEIEN,GEC,FILEIEN)) Q:FILEIEN="" D
...S GECNODE=$G(^PXRMD(801.5,FILEIEN,0))
...S GECT=$P(GECNODE,"^",3),GECDA=$O(^PX(839.7,"B",GECT,0))
...S HFDA=0 F S HFDA=$O(^AUPNVHF("AED",ENCDT,DFN,GECDA,HFDA)) Q:HFDA="" D
....S HFARY(HFDA)=""
...S DA=FILEIEN S DIK="^PXRMD(801.5," D ^DIK
E I $D(^PXRMD(801.5,"ACOPY",NOTEIEN)) D
.S GECT="" F S GECT=$O(^PXRMD(801.5,"ACOPY",NOTEIEN,DFN,ENCDT,GECT)) Q:GECT="" D
..S GECDA=$O(^PX(839.7,"B",GECT,0))
..S HFDA=0 F S HFDA=$O(^AUPNVHF("AED",ENCDT,DFN,GECDA,HFDA)) Q:HFDA="" D
...S HFARY(HFDA)=""
I $D(HFARY) D
.;
.N ZTIO,ZTRTN,ZTDTH,ZTSAVE,ZTDESC,ZTSK,GECIEN,GET
.;
.S ZTIO="ORW/PXAPI RESOURCE"
.S ZTRTN="REMOVE^PXRMGECK"
.S ZTDTH=$H
.S ZTSAVE("GECT")=""
.S ZTSAVE("HFARY(")=""
.S ZTDESC="PXRM remove Health Factors for GEC"
.D ^%ZTLOAD
;Clean up ACOPY nodes
D ACOPYDEL^PXRMGECK
Q
;
API(RESULT,IEN,DFN,VISIT,WHERE,NOTEIEN) ;
I '$D(NOTEIEN) S NOTEIEN=1
N GEC,DFNDT
S GEC=$$CHECKGEC(IEN)
I $G(GEC)="" S RESULT=0_U_"" Q
I GEC="UCS"!(GEC="CRGF")!(GEC="IMMREAD")!(GEC="WHRM")!(GEC="WHRP") S RESULT=0_U_"" Q
I $G(GEC)'["GEC" S RESULT=1_U_$$NOW^XLFDT()_";"_GEC Q
S RESULT=1_U_$$GECDT(DFN,GEC,VISIT,NOTEIEN)_";"_GEC_U_$$EVAL(DFN,GEC,WHERE)
;
Q
;
CHECKGEC(IEN) ;
N RIEN,DIEN
I IEN["R" D
. S RIEN=$E(IEN,2,$L(IEN)) S DIEN=$G(^PXD(811.9,RIEN,51))
. I $G(DIEN)'="" S GEC=$P($G(^PXRMD(801.41,DIEN,0)),U,16)
E S GEC=$P($G(^PXRMD(801.41,IEN,0)),U,16)
Q $G(GEC)
;
GECDT(DFN,GEC,VISIT,NOTEIEN) ;Get Date/Time from file
N STOP
S STOP=0
I $D(^PXRMD(801.5,"B",DFN)) D CURADD
I '$D(^PXRMD(801.5,"B",DFN)) D NEWADD
S DFNDT=$O(^PXRMD(801.5,"AC",DFN,0))
Q DFNDT
;
NEWADD ;-Set Data into File 801.5 and 801.55 (history)
Q:STOP=1
D
.Q:$D(^PXRMD(801.5,"AD",DFN,GEC))
.S GEX(1,801.5,"+1,",.01)=DFN
.S GEX(1,801.5,"+1,",.02)=$$NOW^XLFDT
.S GEX(1,801.5,"+1,",.03)=GEC
.S GEX(1,801.5,"+1,",.04)=+$G(NOTEIEN)
.S GEX(1,801.5,"+1,",.05)=DUZ
.S GEX(1,801.5,"+1,",.06)=DT
.S ^PXRMD(801.5,"ACOPY",+$G(NOTEIEN),DFN,$G(GEX(1,801.5,"+1,",.02)),GEC,DT)=""
.D UPDATE^DIE("","GEX(1)")
;--HISTORY FILE
S GEX(2,801.55,"+1,",.01)=DFN
S GEX(2,801.55,"+1,",.02)=$$NOW^XLFDT
S GEX(2,801.55,"+1,",.03)=GEC
S GEX(2,801.55,"+1,",.04)=+$G(NOTEIEN)
S GEX(2,801.55,"+1,",.05)=DUZ
S GEX(2,801.55,"+1,",.06)=DT
D UPDATE^DIE("","GEX(2)")
K GEX
S STOP=1
Q
CURADD ;-Set Data into File 801.5 and 801.55 (history)
Q:STOP=1
D
.Q:$D(^PXRMD(801.5,"AD",DFN,GEC))
.S GEX(1,801.5,"+1,",.01)=DFN
.S GEX(1,801.5,"+1,",.02)=$O(^PXRMD(801.5,"AC",DFN,0))
.S GEX(1,801.5,"+1,",.03)=GEC
.S GEX(1,801.5,"+1,",.04)=+$G(NOTEIEN)
.S GEX(1,801.5,"+1,",.05)=DUZ
.S GEX(1,801.5,"+1,",.06)=DT
.S ^PXRMD(801.5,"ACOPY",+$G(NOTEIEN),DFN,$G(GEX(1,801.5,"+1,",.02)),GEC,DT)=""
.D UPDATE^DIE("","GEX(1)")
;--HISTORY FILE
S GEX(2,801.55,"+1,",.01)=DFN
S GEX(2,801.55,"+1,",.02)=$O(^PXRMD(801.5,"AC",DFN,0))
S GEX(2,801.55,"+1,",.03)=GEC
S GEX(2,801.55,"+1,",.04)=+$G(NOTEIEN)
S GEX(2,801.55,"+1,",.05)=DUZ
S GEX(2,801.55,"+1,",.06)=DT
D UPDATE^DIE("","GEX(2)")
K GEX
S STOP=1
Q
;
STATUS(DFN) ;Evaluate The status of the Referral
;
N STOP,ZTSK
S STOP=0
I $D(^PXRMD(801.5,"ATASK",DFN)) S ZTSK=$O(^PXRMD(801.5,"ATASK",DFN,0)) D
.D STAT^%ZTLOAD
.I ZTSK(0)=1 D
..I 12[ZTSK(1) D
...S MESSAGE="Data is Changing!! Please Check Status Again^GEC Referral NO Status Available^0"
...S STOP=1
Q:STOP=1 MESSAGE
;
;Returned
;sentence ~ sentence ~ sentence ^ OK or YES/NO BOX
;
N MISSING,MESSAGE,HFDA,STOP,BOX
S BOX=1
D ACOPYDEL^PXRMGECK
;
;GET IEN FOR DATA SOURCES FOR GEC
I $D(^PX(839.7,"B","GEC1")) S GEC1=$O(^PX(839.7,"B","GEC1",""))
I $D(^PX(839.7,"B","GEC2")) S GEC2=$O(^PX(839.7,"B","GEC2",""))
I $D(^PX(839.7,"B","GEC3")) S GEC3=$O(^PX(839.7,"B","GEC3",""))
I $D(^PX(839.7,"B","GECF")) S GECF=$O(^PX(839.7,"B","GECF",""))
;
S STOP=0
S MESSAGE=" No GEC Referral in progress.^GEC Referral Status"
S HFDA="" F S HFDA=$O(^AUPNVHF("C",DFN,HFDA)) Q:HFDA="" Q:STOP=1 D
.I $D(^AUPNVHF(HFDA,12)) D
..I $P($G(^AUPNVHF(HFDA,12)),"^",1)>0 D
...S SOURCE=$P($G(^AUPNVHF(HFDA,812)),"^",3)
...Q:SOURCE=""
...I (SOURCE=$G(GEC1))!(SOURCE=$G(GEC2))!(SOURCE=$G(GEC3))!(SOURCE=$G(GECF)) D
....S STOP=1
;
S (MISSING)=""
I '$D(^PXRMD(801.5,"B",DFN))&(STOP=0) D
.S MESSAGE=" No GEC Referral on record.^Current GEC Referral Status"
Q:'$D(^PXRMD(801.5,"B",DFN)) MESSAGE
S MESSAGE=""
;
;
; A. look for missing dialog
S:'$D(^PXRMD(801.5,"AD",DFN,"GEC1")) MISSING=MISSING_1_"^"
S:'$D(^PXRMD(801.5,"AD",DFN,"GEC2")) MISSING=MISSING_2_"^"
S:'$D(^PXRMD(801.5,"AD",DFN,"GEC3")) MISSING=MISSING_3_"^"
S:'$D(^PXRMD(801.5,"AD",DFN,"GECF")) MISSING=MISSING_4
; a. if none missing then set message
;I MISSING="" D
; b. if missing then create message
I MISSING'=""!(MISSING="") D
.S MESSAGE="The following Dialogs are Complete:~"
.S:MISSING'[1 MESSAGE=MESSAGE_$P($T(T+7),";",3) D
..I +$$TIUSTAT^PXRMGECK(DFN,"GEC1") D
...S MESSAGE=MESSAGE_"~"_" Note is "_$P($$TIUSTAT^PXRMGECK(DFN,"GEC1"),":",2)_" "_$P($$TIUSTAT^PXRMGECK(DFN,"GEC1"),":",4)_"~"
.S:MISSING'[2 MESSAGE=MESSAGE_$P($T(T+8),";",3) D
..I +$$TIUSTAT^PXRMGECK(DFN,"GEC2") D
...S MESSAGE=MESSAGE_"~"_" Note is "_$P($$TIUSTAT^PXRMGECK(DFN,"GEC2"),":",2)_" "_$P($$TIUSTAT^PXRMGECK(DFN,"GEC2"),":",4)_"~"
.S:MISSING'[3 MESSAGE=MESSAGE_$P($T(T+9),";",3) D
..I +$$TIUSTAT^PXRMGECK(DFN,"GEC3") D
...S MESSAGE=MESSAGE_"~"_" Note is "_$P($$TIUSTAT^PXRMGECK(DFN,"GEC3"),":",2)_" "_$P($$TIUSTAT^PXRMGECK(DFN,"GEC3"),":",4)_"~"
.S:MISSING'[4 MESSAGE=MESSAGE_$P($T(T+10),";",3) D
..I +$$TIUSTAT^PXRMGECK(DFN,"GECF") D
...S MESSAGE=MESSAGE_"~"_" Note is "_$P($$TIUSTAT^PXRMGECK(DFN,"GECF"),":",2)_" "_$P($$TIUSTAT^PXRMGECK(DFN,"GECF"),":",4)_"~"
.I $E(MESSAGE,$L(MESSAGE))'="~" S MESSAGE=MESSAGE_"~"
.I MISSING'="" S MESSAGE=MESSAGE_$P($T(T+11),";",3)
.S:MISSING[1 MESSAGE=MESSAGE_$P($T(T+7),";",3)
.S:MISSING[2 MESSAGE=MESSAGE_$P($T(T+8),";",3)
.S:MISSING[3 MESSAGE=MESSAGE_$P($T(T+9),";",3)
.S:MISSING[4 MESSAGE=MESSAGE_$P($T(T+10),";",3)
;
I MISSING="" S MESSAGE=MESSAGE_"~"_$P($T(T+5),";",3)
S MESSAGE=MESSAGE_$P($T(T+6),";",3)
S MESSAGE=MESSAGE_"^Current GEC Referral Status"_"^"_BOX
;
Q MESSAGE
;
EVAL(DFN,GEC,WHERE) ;Evaluate for missing dialogs
;DFN=PATIENT DFN
;GEC=Identify for Dialog
;WHERE=What part of the dialog this call is comming from
; 0=Object at the start
; 1=Finished button
;
;Returned
;Box Header ^ Message ^ Box display Flag
;
;Clean up ACOPY node
D ACOPYDEL^PXRMGECK
;
N MISSING,MESSAGE,DIANAME,FORTH,BOX
;
;Getting the Names fo the dialogs
I GEC="GEC1" S DIANAME=$P($T(T+1),";",3)
I GEC="GEC2" S DIANAME=$P($T(T+2),";",3)
I GEC="GEC3" S DIANAME=$P($T(T+3),";",3)
I GEC="GECF" S DIANAME=$P($T(T+4),";",3)
;
;Check to see if 4th is done;add 1 or 0 to end of message
;if 1 the GUI should bring up a modal box asking if finished
S FORTH=0
S:$D(^PXRMD(801.5,"AD",DFN,"GECF"))!(GEC["GECF") FORTH=1
I 'WHERE S FORTH=0
;
;
S (MISSING,MESSAGE)=""
Q:'$D(^PXRMD(801.5,"B",DFN)) MESSAGE
I WHERE Q:FORTH=0 MESSAGE
;
;
; A. look for missing dialog
S:'$D(^PXRMD(801.5,"AD",DFN,"GEC1"))&(GEC'["GEC1") MISSING=MISSING_1_"^"
S:'$D(^PXRMD(801.5,"AD",DFN,"GEC2"))&(GEC'["GEC2") MISSING=MISSING_2_"^"
S:'$D(^PXRMD(801.5,"AD",DFN,"GEC3"))&(GEC'["GEC3") MISSING=MISSING_3_"^"
S:'$D(^PXRMD(801.5,"AD",DFN,"GECF"))&(GEC'["GECF") MISSING=MISSING_4
; a. if none missing then set message
I MISSING="" D
.I WHERE S MESSAGE=$P($T(T+5),";",3)_$P($T(T+6),";",3)
.I 'WHERE S MESSAGE=$P($T(T+5),";",3)
; b. if missing then create message
I MISSING'="" D
.S MESSAGE="The Following Dialogs are Missing:~"
.S:MISSING[1 MESSAGE=MESSAGE_$P($T(T+7),";",3)
.S:MISSING[2 MESSAGE=MESSAGE_$P($T(T+8),";",3)
.S:MISSING[3 MESSAGE=MESSAGE_$P($T(T+9),";",3)
.S:MISSING[4 MESSAGE=MESSAGE_$P($T(T+10),";",3)
.Q:'WHERE
.S MESSAGE=MESSAGE_$P($T(T+6),";",3)_$P($T(T+12),";",3)_$P($T(T+13),";",3)
;
S BOX="GEC Referral Completion Status"
S MESSAGE=BOX_"^"_MESSAGE_"^"_FORTH
Q MESSAGE
;
T ;TEXT
;; Social Services,
;; Nursing Assessment,
;; Care Recommendations,
;; Care Coordination
;; All Dialogs are Finished.
;; ~~Is this Referral Complete?
;; ~ Social Services
;; ~ Nursing Assessment
;; ~ Care Recommendations
;; ~ Care Coordination
;; ~The Following Dialogs are Missing:~
;; ~~(If you select Yes, the current REFERRAL ~will be completed and the information ~from the missing dialogs cannot be added.
;; ~~If you select No, the current REFERRAL ~remains open.)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMGECU 10065 printed Sep 23, 2025@19:21:51 Page 2
PXRMGECU ;SLC/AGP,JVS - CLINICAL REMINDERS ;Oct 17, 2022@10:07:20
+1 ;;2.0;CLINICAL REMINDERS;**4,83**;Feb 04, 2005;Build 14
+2 QUIT
FINISHED(DFN,ANS) ;Delete 801.5 entries if finished
+1 ;ANS=Answer to YES/NO button should be 1 or will quit
+2 if DFN=""
QUIT
+3 if ANS=0
QUIT
+4 SET PATDA=""
FOR
SET PATDA=$ORDER(^PXRMD(801.5,"B",DFN,PATDA))
if PATDA=""
QUIT
Begin DoDot:1
+5 SET DA=PATDA
SET DIK="^PXRMD(801.5,"
DO ^DIK
End DoDot:1
+6 KILL DA,DIK,PATDA
+7 QUIT
+8 ;
CON(IEN,DFN) ;CHECK TO see if 2 DIA ARE DONE to display consult
+1 NEW OK
+2 ;
+3 SET OK=0
+4 SET GEC1DA=$ORDER(^PXRMD(801.41,"AC","GEC1",0))
+5 SET GEC2DA=$ORDER(^PXRMD(801.41,"AC","GEC2",0))
+6 SET GEC3DA=$ORDER(^PXRMD(801.41,"AC","GEC3",0))
+7 SET GECFDA=$ORDER(^PXRMD(801.41,"AC","GECF",0))
+8 if IEN'=GEC1DA!(IEN'=GEC2DA)!(IEN'=GEC3DA)
QUIT OK
+9 ;
+10 SET CNT=0
+11 IF $DATA(^PXRMD(801.5,"AD",DFN,"GEC1"))
SET CNT=CNT+1
+12 IF $DATA(^PXRMD(801.5,"AD",DFN,"GEC2"))
SET CNT=CNT+1
+13 IF $DATA(^PXRMD(801.5,"AD",DFN,"GEC3"))
SET CNT=CNT+1
+14 ;
+15 IF CNT>1
SET OK=1
+16 QUIT OK
+17 ;
DEL(NOTEIEN) ;Delete HF and 801.5 Called from DELETE^TIUEDI1
+1 NEW DFN,TIUNODE,FILEIEN,GEC,ENCDT,GECNODE,GECT,GECDA,HFDA
+2 NEW HFARY
+3 if '$DATA(^PXRMD(801.5,"ACOPY",NOTEIEN))
QUIT
+4 SET DFN=$ORDER(^PXRMD(801.5,"ACOPY",NOTEIEN,0))
+5 SET ENCDT=$ORDER(^PXRMD(801.5,"ACOPY",NOTEIEN,DFN,0))
+6 IF $DATA(^PXRMD(801.5,"ANOTE",NOTEIEN))
Begin DoDot:1
+7 SET GEC=""
FOR
SET GEC=$ORDER(^PXRMD(801.5,"ANOTE",NOTEIEN,GEC))
if GEC=""
QUIT
Begin DoDot:2
+8 SET FILEIEN=0
FOR
SET FILEIEN=$ORDER(^PXRMD(801.5,"ANOTE",NOTEIEN,GEC,FILEIEN))
if FILEIEN=""
QUIT
Begin DoDot:3
+9 SET GECNODE=$GET(^PXRMD(801.5,FILEIEN,0))
+10 SET GECT=$PIECE(GECNODE,"^",3)
SET GECDA=$ORDER(^PX(839.7,"B",GECT,0))
+11 SET HFDA=0
FOR
SET HFDA=$ORDER(^AUPNVHF("AED",ENCDT,DFN,GECDA,HFDA))
if HFDA=""
QUIT
Begin DoDot:4
+12 SET HFARY(HFDA)=""
End DoDot:4
+13 SET DA=FILEIEN
SET DIK="^PXRMD(801.5,"
DO ^DIK
End DoDot:3
End DoDot:2
End DoDot:1
+14 IF '$TEST
IF $DATA(^PXRMD(801.5,"ACOPY",NOTEIEN))
Begin DoDot:1
+15 SET GECT=""
FOR
SET GECT=$ORDER(^PXRMD(801.5,"ACOPY",NOTEIEN,DFN,ENCDT,GECT))
if GECT=""
QUIT
Begin DoDot:2
+16 SET GECDA=$ORDER(^PX(839.7,"B",GECT,0))
+17 SET HFDA=0
FOR
SET HFDA=$ORDER(^AUPNVHF("AED",ENCDT,DFN,GECDA,HFDA))
if HFDA=""
QUIT
Begin DoDot:3
+18 SET HFARY(HFDA)=""
End DoDot:3
End DoDot:2
End DoDot:1
+19 IF $DATA(HFARY)
Begin DoDot:1
+20 ;
+21 NEW ZTIO,ZTRTN,ZTDTH,ZTSAVE,ZTDESC,ZTSK,GECIEN,GET
+22 ;
+23 SET ZTIO="ORW/PXAPI RESOURCE"
+24 SET ZTRTN="REMOVE^PXRMGECK"
+25 SET ZTDTH=$HOROLOG
+26 SET ZTSAVE("GECT")=""
+27 SET ZTSAVE("HFARY(")=""
+28 SET ZTDESC="PXRM remove Health Factors for GEC"
+29 DO ^%ZTLOAD
End DoDot:1
+30 ;Clean up ACOPY nodes
+31 DO ACOPYDEL^PXRMGECK
+32 QUIT
+33 ;
API(RESULT,IEN,DFN,VISIT,WHERE,NOTEIEN) ;
+1 IF '$DATA(NOTEIEN)
SET NOTEIEN=1
+2 NEW GEC,DFNDT
+3 SET GEC=$$CHECKGEC(IEN)
+4 IF $GET(GEC)=""
SET RESULT=0_U_""
QUIT
+5 IF GEC="UCS"!(GEC="CRGF")!(GEC="IMMREAD")!(GEC="WHRM")!(GEC="WHRP")
SET RESULT=0_U_""
QUIT
+6 IF $GET(GEC)'["GEC"
SET RESULT=1_U_$$NOW^XLFDT()_";"_GEC
QUIT
+7 SET RESULT=1_U_$$GECDT(DFN,GEC,VISIT,NOTEIEN)_";"_GEC_U_$$EVAL(DFN,GEC,WHERE)
+8 ;
+9 QUIT
+10 ;
CHECKGEC(IEN) ;
+1 NEW RIEN,DIEN
+2 IF IEN["R"
Begin DoDot:1
+3 SET RIEN=$EXTRACT(IEN,2,$LENGTH(IEN))
SET DIEN=$GET(^PXD(811.9,RIEN,51))
+4 IF $GET(DIEN)'=""
SET GEC=$PIECE($GET(^PXRMD(801.41,DIEN,0)),U,16)
End DoDot:1
+5 IF '$TEST
SET GEC=$PIECE($GET(^PXRMD(801.41,IEN,0)),U,16)
+6 QUIT $GET(GEC)
+7 ;
GECDT(DFN,GEC,VISIT,NOTEIEN) ;Get Date/Time from file
+1 NEW STOP
+2 SET STOP=0
+3 IF $DATA(^PXRMD(801.5,"B",DFN))
DO CURADD
+4 IF '$DATA(^PXRMD(801.5,"B",DFN))
DO NEWADD
+5 SET DFNDT=$ORDER(^PXRMD(801.5,"AC",DFN,0))
+6 QUIT DFNDT
+7 ;
NEWADD ;-Set Data into File 801.5 and 801.55 (history)
+1 if STOP=1
QUIT
+2 Begin DoDot:1
+3 if $DATA(^PXRMD(801.5,"AD",DFN,GEC))
QUIT
+4 SET GEX(1,801.5,"+1,",.01)=DFN
+5 SET GEX(1,801.5,"+1,",.02)=$$NOW^XLFDT
+6 SET GEX(1,801.5,"+1,",.03)=GEC
+7 SET GEX(1,801.5,"+1,",.04)=+$GET(NOTEIEN)
+8 SET GEX(1,801.5,"+1,",.05)=DUZ
+9 SET GEX(1,801.5,"+1,",.06)=DT
+10 SET ^PXRMD(801.5,"ACOPY",+$GET(NOTEIEN),DFN,$GET(GEX(1,801.5,"+1,",.02)),GEC,DT)=""
+11 DO UPDATE^DIE("","GEX(1)")
End DoDot:1
+12 ;--HISTORY FILE
+13 SET GEX(2,801.55,"+1,",.01)=DFN
+14 SET GEX(2,801.55,"+1,",.02)=$$NOW^XLFDT
+15 SET GEX(2,801.55,"+1,",.03)=GEC
+16 SET GEX(2,801.55,"+1,",.04)=+$GET(NOTEIEN)
+17 SET GEX(2,801.55,"+1,",.05)=DUZ
+18 SET GEX(2,801.55,"+1,",.06)=DT
+19 DO UPDATE^DIE("","GEX(2)")
+20 KILL GEX
+21 SET STOP=1
+22 QUIT
CURADD ;-Set Data into File 801.5 and 801.55 (history)
+1 if STOP=1
QUIT
+2 Begin DoDot:1
+3 if $DATA(^PXRMD(801.5,"AD",DFN,GEC))
QUIT
+4 SET GEX(1,801.5,"+1,",.01)=DFN
+5 SET GEX(1,801.5,"+1,",.02)=$ORDER(^PXRMD(801.5,"AC",DFN,0))
+6 SET GEX(1,801.5,"+1,",.03)=GEC
+7 SET GEX(1,801.5,"+1,",.04)=+$GET(NOTEIEN)
+8 SET GEX(1,801.5,"+1,",.05)=DUZ
+9 SET GEX(1,801.5,"+1,",.06)=DT
+10 SET ^PXRMD(801.5,"ACOPY",+$GET(NOTEIEN),DFN,$GET(GEX(1,801.5,"+1,",.02)),GEC,DT)=""
+11 DO UPDATE^DIE("","GEX(1)")
End DoDot:1
+12 ;--HISTORY FILE
+13 SET GEX(2,801.55,"+1,",.01)=DFN
+14 SET GEX(2,801.55,"+1,",.02)=$ORDER(^PXRMD(801.5,"AC",DFN,0))
+15 SET GEX(2,801.55,"+1,",.03)=GEC
+16 SET GEX(2,801.55,"+1,",.04)=+$GET(NOTEIEN)
+17 SET GEX(2,801.55,"+1,",.05)=DUZ
+18 SET GEX(2,801.55,"+1,",.06)=DT
+19 DO UPDATE^DIE("","GEX(2)")
+20 KILL GEX
+21 SET STOP=1
+22 QUIT
+23 ;
STATUS(DFN) ;Evaluate The status of the Referral
+1 ;
+2 NEW STOP,ZTSK
+3 SET STOP=0
+4 IF $DATA(^PXRMD(801.5,"ATASK",DFN))
SET ZTSK=$ORDER(^PXRMD(801.5,"ATASK",DFN,0))
Begin DoDot:1
+5 DO STAT^%ZTLOAD
+6 IF ZTSK(0)=1
Begin DoDot:2
+7 IF 12[ZTSK(1)
Begin DoDot:3
+8 SET MESSAGE="Data is Changing!! Please Check Status Again^GEC Referral NO Status Available^0"
+9 SET STOP=1
End DoDot:3
End DoDot:2
End DoDot:1
+10 if STOP=1
QUIT MESSAGE
+11 ;
+12 ;Returned
+13 ;sentence ~ sentence ~ sentence ^ OK or YES/NO BOX
+14 ;
+15 NEW MISSING,MESSAGE,HFDA,STOP,BOX
+16 SET BOX=1
+17 DO ACOPYDEL^PXRMGECK
+18 ;
+19 ;GET IEN FOR DATA SOURCES FOR GEC
+20 IF $DATA(^PX(839.7,"B","GEC1"))
SET GEC1=$ORDER(^PX(839.7,"B","GEC1",""))
+21 IF $DATA(^PX(839.7,"B","GEC2"))
SET GEC2=$ORDER(^PX(839.7,"B","GEC2",""))
+22 IF $DATA(^PX(839.7,"B","GEC3"))
SET GEC3=$ORDER(^PX(839.7,"B","GEC3",""))
+23 IF $DATA(^PX(839.7,"B","GECF"))
SET GECF=$ORDER(^PX(839.7,"B","GECF",""))
+24 ;
+25 SET STOP=0
+26 SET MESSAGE=" No GEC Referral in progress.^GEC Referral Status"
+27 SET HFDA=""
FOR
SET HFDA=$ORDER(^AUPNVHF("C",DFN,HFDA))
if HFDA=""
QUIT
if STOP=1
QUIT
Begin DoDot:1
+28 IF $DATA(^AUPNVHF(HFDA,12))
Begin DoDot:2
+29 IF $PIECE($GET(^AUPNVHF(HFDA,12)),"^",1)>0
Begin DoDot:3
+30 SET SOURCE=$PIECE($GET(^AUPNVHF(HFDA,812)),"^",3)
+31 if SOURCE=""
QUIT
+32 IF (SOURCE=$GET(GEC1))!(SOURCE=$GET(GEC2))!(SOURCE=$GET(GEC3))!(SOURCE=$GET(GECF))
Begin DoDot:4
+33 SET STOP=1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+34 ;
+35 SET (MISSING)=""
+36 IF '$DATA(^PXRMD(801.5,"B",DFN))&(STOP=0)
Begin DoDot:1
+37 SET MESSAGE=" No GEC Referral on record.^Current GEC Referral Status"
End DoDot:1
+38 if '$DATA(^PXRMD(801.5,"B",DFN))
QUIT MESSAGE
+39 SET MESSAGE=""
+40 ;
+41 ;
+42 ; A. look for missing dialog
+43 if '$DATA(^PXRMD(801.5,"AD",DFN,"GEC1"))
SET MISSING=MISSING_1_"^"
+44 if '$DATA(^PXRMD(801.5,"AD",DFN,"GEC2"))
SET MISSING=MISSING_2_"^"
+45 if '$DATA(^PXRMD(801.5,"AD",DFN,"GEC3"))
SET MISSING=MISSING_3_"^"
+46 if '$DATA(^PXRMD(801.5,"AD",DFN,"GECF"))
SET MISSING=MISSING_4
+47 ; a. if none missing then set message
+48 ;I MISSING="" D
+49 ; b. if missing then create message
+50 IF MISSING'=""!(MISSING="")
Begin DoDot:1
+51 SET MESSAGE="The following Dialogs are Complete:~"
+52 if MISSING'[1
SET MESSAGE=MESSAGE_$PIECE($TEXT(T+7),";",3)
Begin DoDot:2
+53 IF +$$TIUSTAT^PXRMGECK(DFN,"GEC1")
Begin DoDot:3
+54 SET MESSAGE=MESSAGE_"~"_" Note is "_$PIECE($$TIUSTAT^PXRMGECK(DFN,"GEC1"),":",2)_" "_$PIECE($$TIUSTAT^PXRMGECK(DFN,"GEC1"),":",4)_"~"
End DoDot:3
End DoDot:2
+55 if MISSING'[2
SET MESSAGE=MESSAGE_$PIECE($TEXT(T+8),";",3)
Begin DoDot:2
+56 IF +$$TIUSTAT^PXRMGECK(DFN,"GEC2")
Begin DoDot:3
+57 SET MESSAGE=MESSAGE_"~"_" Note is "_$PIECE($$TIUSTAT^PXRMGECK(DFN,"GEC2"),":",2)_" "_$PIECE($$TIUSTAT^PXRMGECK(DFN,"GEC2"),":",4)_"~"
End DoDot:3
End DoDot:2
+58 if MISSING'[3
SET MESSAGE=MESSAGE_$PIECE($TEXT(T+9),";",3)
Begin DoDot:2
+59 IF +$$TIUSTAT^PXRMGECK(DFN,"GEC3")
Begin DoDot:3
+60 SET MESSAGE=MESSAGE_"~"_" Note is "_$PIECE($$TIUSTAT^PXRMGECK(DFN,"GEC3"),":",2)_" "_$PIECE($$TIUSTAT^PXRMGECK(DFN,"GEC3"),":",4)_"~"
End DoDot:3
End DoDot:2
+61 if MISSING'[4
SET MESSAGE=MESSAGE_$PIECE($TEXT(T+10),";",3)
Begin DoDot:2
+62 IF +$$TIUSTAT^PXRMGECK(DFN,"GECF")
Begin DoDot:3
+63 SET MESSAGE=MESSAGE_"~"_" Note is "_$PIECE($$TIUSTAT^PXRMGECK(DFN,"GECF"),":",2)_" "_$PIECE($$TIUSTAT^PXRMGECK(DFN,"GECF"),":",4)_"~"
End DoDot:3
End DoDot:2
+64 IF $EXTRACT(MESSAGE,$LENGTH(MESSAGE))'="~"
SET MESSAGE=MESSAGE_"~"
+65 IF MISSING'=""
SET MESSAGE=MESSAGE_$PIECE($TEXT(T+11),";",3)
+66 if MISSING[1
SET MESSAGE=MESSAGE_$PIECE($TEXT(T+7),";",3)
+67 if MISSING[2
SET MESSAGE=MESSAGE_$PIECE($TEXT(T+8),";",3)
+68 if MISSING[3
SET MESSAGE=MESSAGE_$PIECE($TEXT(T+9),";",3)
+69 if MISSING[4
SET MESSAGE=MESSAGE_$PIECE($TEXT(T+10),";",3)
End DoDot:1
+70 ;
+71 IF MISSING=""
SET MESSAGE=MESSAGE_"~"_$PIECE($TEXT(T+5),";",3)
+72 SET MESSAGE=MESSAGE_$PIECE($TEXT(T+6),";",3)
+73 SET MESSAGE=MESSAGE_"^Current GEC Referral Status"_"^"_BOX
+74 ;
+75 QUIT MESSAGE
+76 ;
EVAL(DFN,GEC,WHERE) ;Evaluate for missing dialogs
+1 ;DFN=PATIENT DFN
+2 ;GEC=Identify for Dialog
+3 ;WHERE=What part of the dialog this call is comming from
+4 ; 0=Object at the start
+5 ; 1=Finished button
+6 ;
+7 ;Returned
+8 ;Box Header ^ Message ^ Box display Flag
+9 ;
+10 ;Clean up ACOPY node
+11 DO ACOPYDEL^PXRMGECK
+12 ;
+13 NEW MISSING,MESSAGE,DIANAME,FORTH,BOX
+14 ;
+15 ;Getting the Names fo the dialogs
+16 IF GEC="GEC1"
SET DIANAME=$PIECE($TEXT(T+1),";",3)
+17 IF GEC="GEC2"
SET DIANAME=$PIECE($TEXT(T+2),";",3)
+18 IF GEC="GEC3"
SET DIANAME=$PIECE($TEXT(T+3),";",3)
+19 IF GEC="GECF"
SET DIANAME=$PIECE($TEXT(T+4),";",3)
+20 ;
+21 ;Check to see if 4th is done;add 1 or 0 to end of message
+22 ;if 1 the GUI should bring up a modal box asking if finished
+23 SET FORTH=0
+24 if $DATA(^PXRMD(801.5,"AD",DFN,"GECF"))!(GEC["GECF")
SET FORTH=1
+25 IF 'WHERE
SET FORTH=0
+26 ;
+27 ;
+28 SET (MISSING,MESSAGE)=""
+29 if '$DATA(^PXRMD(801.5,"B",DFN))
QUIT MESSAGE
+30 IF WHERE
if FORTH=0
QUIT MESSAGE
+31 ;
+32 ;
+33 ; A. look for missing dialog
+34 if '$DATA(^PXRMD(801.5,"AD",DFN,"GEC1"))&(GEC'["GEC1")
SET MISSING=MISSING_1_"^"
+35 if '$DATA(^PXRMD(801.5,"AD",DFN,"GEC2"))&(GEC'["GEC2")
SET MISSING=MISSING_2_"^"
+36 if '$DATA(^PXRMD(801.5,"AD",DFN,"GEC3"))&(GEC'["GEC3")
SET MISSING=MISSING_3_"^"
+37 if '$DATA(^PXRMD(801.5,"AD",DFN,"GECF"))&(GEC'["GECF")
SET MISSING=MISSING_4
+38 ; a. if none missing then set message
+39 IF MISSING=""
Begin DoDot:1
+40 IF WHERE
SET MESSAGE=$PIECE($TEXT(T+5),";",3)_$PIECE($TEXT(T+6),";",3)
+41 IF 'WHERE
SET MESSAGE=$PIECE($TEXT(T+5),";",3)
End DoDot:1
+42 ; b. if missing then create message
+43 IF MISSING'=""
Begin DoDot:1
+44 SET MESSAGE="The Following Dialogs are Missing:~"
+45 if MISSING[1
SET MESSAGE=MESSAGE_$PIECE($TEXT(T+7),";",3)
+46 if MISSING[2
SET MESSAGE=MESSAGE_$PIECE($TEXT(T+8),";",3)
+47 if MISSING[3
SET MESSAGE=MESSAGE_$PIECE($TEXT(T+9),";",3)
+48 if MISSING[4
SET MESSAGE=MESSAGE_$PIECE($TEXT(T+10),";",3)
+49 if 'WHERE
QUIT
+50 SET MESSAGE=MESSAGE_$PIECE($TEXT(T+6),";",3)_$PIECE($TEXT(T+12),";",3)_$PIECE($TEXT(T+13),";",3)
End DoDot:1
+51 ;
+52 SET BOX="GEC Referral Completion Status"
+53 SET MESSAGE=BOX_"^"_MESSAGE_"^"_FORTH
+54 QUIT MESSAGE
+55 ;
T ;TEXT
+1 ;; Social Services,
+2 ;; Nursing Assessment,
+3 ;; Care Recommendations,
+4 ;; Care Coordination
+5 ;; All Dialogs are Finished.
+6 ;; ~~Is this Referral Complete?
+7 ;; ~ Social Services
+8 ;; ~ Nursing Assessment
+9 ;; ~ Care Recommendations
+10 ;; ~ Care Coordination
+11 ;; ~The Following Dialogs are Missing:~
+12 ;; ~~(If you select Yes, the current REFERRAL ~will be completed and the information ~from the missing dialogs cannot be added.
+13 ;; ~~If you select No, the current REFERRAL ~remains open.)
+14 QUIT
