Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PXRMGECU

PXRMGECU.m

Go to the documentation of this file. 
  1. PXRMGECU ;SLC/AGP,JVS - CLINICAL REMINDERS ;Oct 17, 2022@10:07:20
  1.  ;;2.0;CLINICAL REMINDERS;**4,83**;Feb 04, 2005;Build 14
  1.  Q
  1. FINISHED(DFN,ANS) ;Delete 801.5 entries if finished
  1.  ;ANS=Answer to YES/NO button should be 1 or will quit
  1.  Q:DFN=""
  1.  Q:ANS=0
  1.  S PATDA="" F  S PATDA=$O(^PXRMD(801.5,"B",DFN,PATDA)) Q:PATDA=""  D
  1.  .S DA=PATDA,DIK="^PXRMD(801.5," D ^DIK
  1.  K DA,DIK,PATDA
  1.  Q
  1.  ;
  1. CON(IEN,DFN) ;CHECK TO see if 2 DIA ARE DONE to display consult
  1.  N OK
  1.  ;
  1.  S OK=0
  1.  S GEC1DA=$O(^PXRMD(801.41,"AC","GEC1",0))
  1.  S GEC2DA=$O(^PXRMD(801.41,"AC","GEC2",0))
  1.  S GEC3DA=$O(^PXRMD(801.41,"AC","GEC3",0))
  1.  S GECFDA=$O(^PXRMD(801.41,"AC","GECF",0))
  1.  Q:IEN'=GEC1DA!(IEN'=GEC2DA)!(IEN'=GEC3DA) OK
  1.  ;
  1.  S CNT=0
  1.  I $D(^PXRMD(801.5,"AD",DFN,"GEC1")) S CNT=CNT+1
  1.  I $D(^PXRMD(801.5,"AD",DFN,"GEC2")) S CNT=CNT+1
  1.  I $D(^PXRMD(801.5,"AD",DFN,"GEC3")) S CNT=CNT+1
  1.  ;
  1.  I CNT>1 S OK=1
  1.  Q OK
  1.  ;
  1. DEL(NOTEIEN) ;Delete HF and 801.5 Called from DELETE^TIUEDI1
  1.  N DFN,TIUNODE,FILEIEN,GEC,ENCDT,GECNODE,GECT,GECDA,HFDA
  1.  N HFARY
  1.  Q:'$D(^PXRMD(801.5,"ACOPY",NOTEIEN))
  1.  S DFN=$O(^PXRMD(801.5,"ACOPY",NOTEIEN,0))
  1.  S ENCDT=$O(^PXRMD(801.5,"ACOPY",NOTEIEN,DFN,0))
  1.  I $D(^PXRMD(801.5,"ANOTE",NOTEIEN)) D
  1.  .S GEC="" F  S GEC=$O(^PXRMD(801.5,"ANOTE",NOTEIEN,GEC)) Q:GEC=""  D
  1.  ..S FILEIEN=0 F  S FILEIEN=$O(^PXRMD(801.5,"ANOTE",NOTEIEN,GEC,FILEIEN)) Q:FILEIEN=""  D
  1.  ...S GECNODE=$G(^PXRMD(801.5,FILEIEN,0))
  1.  ...S GECT=$P(GECNODE,"^",3),GECDA=$O(^PX(839.7,"B",GECT,0))
  1.  ...S HFDA=0 F  S HFDA=$O(^AUPNVHF("AED",ENCDT,DFN,GECDA,HFDA)) Q:HFDA=""  D
  1.  ....S HFARY(HFDA)=""
  1.  ...S DA=FILEIEN S DIK="^PXRMD(801.5," D ^DIK
  1.  E  I $D(^PXRMD(801.5,"ACOPY",NOTEIEN)) D
  1.  .S GECT="" F  S GECT=$O(^PXRMD(801.5,"ACOPY",NOTEIEN,DFN,ENCDT,GECT)) Q:GECT=""  D
  1.  ..S GECDA=$O(^PX(839.7,"B",GECT,0))
  1.  ..S HFDA=0 F  S HFDA=$O(^AUPNVHF("AED",ENCDT,DFN,GECDA,HFDA)) Q:HFDA=""  D
  1.  ...S HFARY(HFDA)=""
  1.  I $D(HFARY) D
  1.  .;
  1.  .N ZTIO,ZTRTN,ZTDTH,ZTSAVE,ZTDESC,ZTSK,GECIEN,GET
  1.  .;
  1.  .S ZTIO="ORW/PXAPI RESOURCE"
  1.  .S ZTRTN="REMOVE^PXRMGECK"
  1.  .S ZTDTH=$H
  1.  .S ZTSAVE("GECT")=""
  1.  .S ZTSAVE("HFARY(")=""
  1.  .S ZTDESC="PXRM remove Health Factors for GEC"
  1.  .D ^%ZTLOAD
  1.  ;Clean up ACOPY nodes
  1.  D ACOPYDEL^PXRMGECK
  1.  Q
  1.  ;
  1. API(RESULT,IEN,DFN,VISIT,WHERE,NOTEIEN) ;
  1.  I '$D(NOTEIEN) S NOTEIEN=1
  1.  N GEC,DFNDT
  1.  S GEC=$$CHECKGEC(IEN)
  1.  I $G(GEC)="" S RESULT=0_U_"" Q
  1.  I GEC="UCS"!(GEC="CRGF")!(GEC="IMMREAD")!(GEC="WHRM")!(GEC="WHRP") S RESULT=0_U_"" Q
  1.  I $G(GEC)'["GEC" S RESULT=1_U_$$NOW^XLFDT()_";"_GEC Q
  1.  S RESULT=1_U_$$GECDT(DFN,GEC,VISIT,NOTEIEN)_";"_GEC_U_$$EVAL(DFN,GEC,WHERE)
  1.  ;
  1.  Q
  1.  ;
  1. CHECKGEC(IEN) ;
  1.  N RIEN,DIEN
  1.  I IEN["R" D
  1.  . S RIEN=$E(IEN,2,$L(IEN)) S DIEN=$G(^PXD(811.9,RIEN,51))
  1.  . I $G(DIEN)'="" S GEC=$P($G(^PXRMD(801.41,DIEN,0)),U,16)
  1.  E  S GEC=$P($G(^PXRMD(801.41,IEN,0)),U,16)
  1.  Q $G(GEC)
  1.  ;
  1. GECDT(DFN,GEC,VISIT,NOTEIEN) ;Get Date/Time from file
  1.  N STOP
  1.  S STOP=0
  1.  I $D(^PXRMD(801.5,"B",DFN)) D CURADD
  1.  I '$D(^PXRMD(801.5,"B",DFN)) D NEWADD
  1.  S DFNDT=$O(^PXRMD(801.5,"AC",DFN,0))
  1.  Q DFNDT
  1.  ;
  1. NEWADD ;-Set Data into File 801.5 and 801.55 (history)
  1.  Q:STOP=1
  1.  D
  1.  .Q:$D(^PXRMD(801.5,"AD",DFN,GEC))
  1.  .S GEX(1,801.5,"+1,",.01)=DFN
  1.  .S GEX(1,801.5,"+1,",.02)=$$NOW^XLFDT
  1.  .S GEX(1,801.5,"+1,",.03)=GEC
  1.  .S GEX(1,801.5,"+1,",.04)=+$G(NOTEIEN)
  1.  .S GEX(1,801.5,"+1,",.05)=DUZ
  1.  .S GEX(1,801.5,"+1,",.06)=DT
  1.  .S ^PXRMD(801.5,"ACOPY",+$G(NOTEIEN),DFN,$G(GEX(1,801.5,"+1,",.02)),GEC,DT)=""
  1.  .D UPDATE^DIE("","GEX(1)")
  1.  ;--HISTORY FILE
  1.  S GEX(2,801.55,"+1,",.01)=DFN
  1.  S GEX(2,801.55,"+1,",.02)=$$NOW^XLFDT
  1.  S GEX(2,801.55,"+1,",.03)=GEC
  1.  S GEX(2,801.55,"+1,",.04)=+$G(NOTEIEN)
  1.  S GEX(2,801.55,"+1,",.05)=DUZ
  1.  S GEX(2,801.55,"+1,",.06)=DT
  1.  D UPDATE^DIE("","GEX(2)")
  1.  K GEX
  1.  S STOP=1
  1.  Q
  1. CURADD ;-Set Data into File 801.5 and 801.55 (history)
  1.  Q:STOP=1
  1.  D
  1.  .Q:$D(^PXRMD(801.5,"AD",DFN,GEC))
  1.  .S GEX(1,801.5,"+1,",.01)=DFN
  1.  .S GEX(1,801.5,"+1,",.02)=$O(^PXRMD(801.5,"AC",DFN,0))
  1.  .S GEX(1,801.5,"+1,",.03)=GEC
  1.  .S GEX(1,801.5,"+1,",.04)=+$G(NOTEIEN)
  1.  .S GEX(1,801.5,"+1,",.05)=DUZ
  1.  .S GEX(1,801.5,"+1,",.06)=DT
  1.  .S ^PXRMD(801.5,"ACOPY",+$G(NOTEIEN),DFN,$G(GEX(1,801.5,"+1,",.02)),GEC,DT)=""
  1.  .D UPDATE^DIE("","GEX(1)")
  1.  ;--HISTORY FILE
  1.  S GEX(2,801.55,"+1,",.01)=DFN
  1.  S GEX(2,801.55,"+1,",.02)=$O(^PXRMD(801.5,"AC",DFN,0))
  1.  S GEX(2,801.55,"+1,",.03)=GEC
  1.  S GEX(2,801.55,"+1,",.04)=+$G(NOTEIEN)
  1.  S GEX(2,801.55,"+1,",.05)=DUZ
  1.  S GEX(2,801.55,"+1,",.06)=DT
  1.  D UPDATE^DIE("","GEX(2)")
  1.  K GEX
  1.  S STOP=1
  1.  Q
  1.  ;
  1. STATUS(DFN) ;Evaluate The status of the Referral
  1.  ;
  1.  N STOP,ZTSK
  1.  S STOP=0
  1.  I $D(^PXRMD(801.5,"ATASK",DFN)) S ZTSK=$O(^PXRMD(801.5,"ATASK",DFN,0)) D
  1.  .D STAT^%ZTLOAD
  1.  .I ZTSK(0)=1 D
  1.  ..I 12[ZTSK(1) D
  1.  ...S MESSAGE="Data is Changing!! Please Check Status Again^GEC Referral NO Status Available^0"
  1.  ...S STOP=1
  1.  Q:STOP=1 MESSAGE
  1.  ;
  1.  ;Returned
  1.  ;sentence ~ sentence ~ sentence ^ OK or YES/NO BOX
  1.  ;
  1.  N MISSING,MESSAGE,HFDA,STOP,BOX
  1.  S BOX=1
  1.  D ACOPYDEL^PXRMGECK
  1.  ;
  1.  ;GET IEN FOR DATA SOURCES FOR GEC
  1.  I $D(^PX(839.7,"B","GEC1")) S GEC1=$O(^PX(839.7,"B","GEC1",""))
  1.  I $D(^PX(839.7,"B","GEC2")) S GEC2=$O(^PX(839.7,"B","GEC2",""))
  1.  I $D(^PX(839.7,"B","GEC3")) S GEC3=$O(^PX(839.7,"B","GEC3",""))
  1.  I $D(^PX(839.7,"B","GECF")) S GECF=$O(^PX(839.7,"B","GECF",""))
  1.  ;
  1.  S STOP=0
  1.  S MESSAGE=" No GEC Referral in progress.^GEC Referral Status"
  1.  S HFDA="" F  S HFDA=$O(^AUPNVHF("C",DFN,HFDA)) Q:HFDA=""  Q:STOP=1  D
  1.  .I $D(^AUPNVHF(HFDA,12)) D
  1.  ..I $P($G(^AUPNVHF(HFDA,12)),"^",1)>0 D
  1.  ...S SOURCE=$P($G(^AUPNVHF(HFDA,812)),"^",3)
  1.  ...Q:SOURCE=""
  1.  ...I (SOURCE=$G(GEC1))!(SOURCE=$G(GEC2))!(SOURCE=$G(GEC3))!(SOURCE=$G(GECF)) D
  1.  ....S STOP=1
  1.  ;
  1.  S (MISSING)=""
  1.  I '$D(^PXRMD(801.5,"B",DFN))&(STOP=0) D
  1.  .S MESSAGE=" No GEC Referral on record.^Current GEC Referral Status"
  1.  Q:'$D(^PXRMD(801.5,"B",DFN)) MESSAGE
  1.  S MESSAGE=""
  1.  ;
  1.  ;
  1.  ; A. look for missing dialog
  1.  S:'$D(^PXRMD(801.5,"AD",DFN,"GEC1")) MISSING=MISSING_1_"^"
  1.  S:'$D(^PXRMD(801.5,"AD",DFN,"GEC2")) MISSING=MISSING_2_"^"
  1.  S:'$D(^PXRMD(801.5,"AD",DFN,"GEC3")) MISSING=MISSING_3_"^"
  1.  S:'$D(^PXRMD(801.5,"AD",DFN,"GECF")) MISSING=MISSING_4
  1.  ;    a. if none missing then set message
  1.  ;I MISSING="" D
  1.  ;    b. if missing then create message
  1.  I MISSING'=""!(MISSING="") D
  1.  .S MESSAGE="The following Dialogs are Complete:~"
  1.  .S:MISSING'[1 MESSAGE=MESSAGE_$P($T(T+7),";",3) D
  1.  ..I +$$TIUSTAT^PXRMGECK(DFN,"GEC1") D
  1.  ...S MESSAGE=MESSAGE_"~"_"       Note is "_$P($$TIUSTAT^PXRMGECK(DFN,"GEC1"),":",2)_"    "_$P($$TIUSTAT^PXRMGECK(DFN,"GEC1"),":",4)_"~"
  1.  .S:MISSING'[2 MESSAGE=MESSAGE_$P($T(T+8),";",3) D
  1.  ..I +$$TIUSTAT^PXRMGECK(DFN,"GEC2") D
  1.  ...S MESSAGE=MESSAGE_"~"_"       Note is "_$P($$TIUSTAT^PXRMGECK(DFN,"GEC2"),":",2)_"    "_$P($$TIUSTAT^PXRMGECK(DFN,"GEC2"),":",4)_"~"
  1.  .S:MISSING'[3 MESSAGE=MESSAGE_$P($T(T+9),";",3) D
  1.  ..I +$$TIUSTAT^PXRMGECK(DFN,"GEC3") D
  1.  ...S MESSAGE=MESSAGE_"~"_"       Note is "_$P($$TIUSTAT^PXRMGECK(DFN,"GEC3"),":",2)_"    "_$P($$TIUSTAT^PXRMGECK(DFN,"GEC3"),":",4)_"~"
  1.  .S:MISSING'[4 MESSAGE=MESSAGE_$P($T(T+10),";",3) D
  1.  ..I +$$TIUSTAT^PXRMGECK(DFN,"GECF") D
  1.  ...S MESSAGE=MESSAGE_"~"_"       Note is "_$P($$TIUSTAT^PXRMGECK(DFN,"GECF"),":",2)_"    "_$P($$TIUSTAT^PXRMGECK(DFN,"GECF"),":",4)_"~"
  1.  .I $E(MESSAGE,$L(MESSAGE))'="~" S MESSAGE=MESSAGE_"~"
  1.  .I MISSING'="" S MESSAGE=MESSAGE_$P($T(T+11),";",3)
  1.  .S:MISSING[1 MESSAGE=MESSAGE_$P($T(T+7),";",3)
  1.  .S:MISSING[2 MESSAGE=MESSAGE_$P($T(T+8),";",3)
  1.  .S:MISSING[3 MESSAGE=MESSAGE_$P($T(T+9),";",3)
  1.  .S:MISSING[4 MESSAGE=MESSAGE_$P($T(T+10),";",3)
  1.  ;
  1.  I MISSING="" S MESSAGE=MESSAGE_"~"_$P($T(T+5),";",3)
  1.  S MESSAGE=MESSAGE_$P($T(T+6),";",3)
  1.  S MESSAGE=MESSAGE_"^Current GEC Referral Status"_"^"_BOX
  1.  ;
  1.  Q MESSAGE
  1.  ;
  1. EVAL(DFN,GEC,WHERE) ;Evaluate for missing dialogs
  1.  ;DFN=PATIENT DFN
  1.  ;GEC=Identify for Dialog
  1.  ;WHERE=What part of the dialog this call is comming from
  1.  ; 0=Object at the start
  1.  ; 1=Finished button
  1.  ;
  1.  ;Returned
  1.  ;Box Header ^  Message ^ Box display Flag
  1.  ;
  1.  ;Clean up ACOPY node
  1.  D ACOPYDEL^PXRMGECK
  1.  ;
  1.  N MISSING,MESSAGE,DIANAME,FORTH,BOX
  1.  ;
  1.  ;Getting the Names fo the dialogs
  1.  I GEC="GEC1" S DIANAME=$P($T(T+1),";",3)
  1.  I GEC="GEC2" S DIANAME=$P($T(T+2),";",3)
  1.  I GEC="GEC3" S DIANAME=$P($T(T+3),";",3)
  1.  I GEC="GECF" S DIANAME=$P($T(T+4),";",3)
  1.  ;
  1.  ;Check to see if 4th is done;add 1 or 0 to end of message
  1.  ;if 1 the GUI should bring up a modal box asking if finished
  1.  S FORTH=0
  1.  S:$D(^PXRMD(801.5,"AD",DFN,"GECF"))!(GEC["GECF") FORTH=1
  1.  I 'WHERE S FORTH=0
  1.  ;
  1.  ;
  1.  S (MISSING,MESSAGE)=""
  1.  Q:'$D(^PXRMD(801.5,"B",DFN)) MESSAGE
  1.  I WHERE Q:FORTH=0 MESSAGE
  1.  ;
  1.  ;
  1.  ; A. look for missing dialog
  1.  S:'$D(^PXRMD(801.5,"AD",DFN,"GEC1"))&(GEC'["GEC1") MISSING=MISSING_1_"^"
  1.  S:'$D(^PXRMD(801.5,"AD",DFN,"GEC2"))&(GEC'["GEC2") MISSING=MISSING_2_"^"
  1.  S:'$D(^PXRMD(801.5,"AD",DFN,"GEC3"))&(GEC'["GEC3") MISSING=MISSING_3_"^"
  1.  S:'$D(^PXRMD(801.5,"AD",DFN,"GECF"))&(GEC'["GECF") MISSING=MISSING_4
  1.  ;    a. if none missing then set message
  1.  I MISSING="" D
  1.  .I WHERE S MESSAGE=$P($T(T+5),";",3)_$P($T(T+6),";",3)
  1.  .I 'WHERE S MESSAGE=$P($T(T+5),";",3)
  1.  ;    b. if missing then create message
  1.  I MISSING'="" D
  1.  .S MESSAGE="The Following Dialogs are Missing:~"
  1.  .S:MISSING[1 MESSAGE=MESSAGE_$P($T(T+7),";",3)
  1.  .S:MISSING[2 MESSAGE=MESSAGE_$P($T(T+8),";",3)
  1.  .S:MISSING[3 MESSAGE=MESSAGE_$P($T(T+9),";",3)
  1.  .S:MISSING[4 MESSAGE=MESSAGE_$P($T(T+10),";",3)
  1.  .Q:'WHERE
  1.  .S MESSAGE=MESSAGE_$P($T(T+6),";",3)_$P($T(T+12),";",3)_$P($T(T+13),";",3)
  1.  ;
  1.  S BOX="GEC Referral Completion Status"
  1.  S MESSAGE=BOX_"^"_MESSAGE_"^"_FORTH
  1.  Q MESSAGE
  1.  ;
  1. T ;TEXT
  1.  ;; Social Services,
  1.  ;; Nursing Assessment,
  1.  ;; Care Recommendations,
  1.  ;; Care Coordination
  1.  ;; All Dialogs are Finished.
  1.  ;; ~~Is this Referral Complete?
  1.  ;; ~    Social Services
  1.  ;; ~    Nursing Assessment
  1.  ;; ~    Care Recommendations
  1.  ;; ~    Care Coordination
  1.  ;; ~The Following Dialogs are Missing:~
  1.  ;; ~~(If you select Yes, the current REFERRAL ~will be completed and the information ~from the missing dialogs cannot be added.
  1.  ;; ~~If you select No, the current REFERRAL ~remains open.)
  1.  Q