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

PXRMGECJ.m

Go to the documentation of this file. 
  1. PXRMGECJ ;SLC/AGP,JVS - Restore Func ;7/14/05  10:42
  1.  ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  1.  ;Restore GEC Referral to open status
  1.  Q
  1.  ;
  1. EN ;Starting point
  1.  N DIR,DA,DFN,STATUS,NAME,STAMP,CNT,FIRST,SECOND,DIRUT
  1.  K ^TMP("PXRMGEC_CK1",$J),DIR(0),^TMP("PXRMGEC_CK2",$J)
  1.  D PAT
  1.  I $D(DIRUT) Q
  1.  ;
  1. DISP ;Display referrals and data
  1.  N LOC,DIV,SSN,AGE
  1.  S NAME=$P(^DPT(DFN,0),"^",1)
  1.  S LOC=$S($D(^DPT(DFN,.1)):"INPATIENT",1:"OUTPATIENT")
  1.  S DIV=$$GET1^DIQ(2,DFN,.19) I DIV="" S DIV="Unknown"
  1.  S SSN=$$GET1^DIQ(2,DFN,.09)
  1.  S AGE=$$GET1^DIQ(2,DFN,.033)
  1.  S STATUS=$$CK1(DFN)_"^"_$$CK2(DFN)
  1.  ;
  1.  ;
  1.  W !,"================================================================================"
  1.  W !,NAME," (",SSN,") "," AGE:",AGE,"  ",LOC,"  ",DIV," Division",!
  1.  W !,?5,"Current Open Referral::"
  1.  I +STATUS=0 W !,?10,"< N O N E >"
  1.  I +STATUS=1 D
  1.  .N I,DATE,DIALOG,USER,STAMP
  1.  .S I=0 F  S I=$O(^TMP("PXRMGEC_CK1",$J,I)) Q:I=""  D
  1.  ..S J=0 F  S J=$O(^TMP("PXRMGEC_CK1",$J,I,J)) Q:J=""  D
  1.  ...S STAMP=$P(^TMP("PXRMGEC_CK1",$J,I,J),"^",2) I STAMP'="" S STAMP=$$FMTE^XLFDT(STAMP,"1P")
  1.  ...S DIALOG=$$DIALOG($P(^TMP("PXRMGEC_CK1",$J,I,J),"^",3))
  1.  ...S USER=$P(^TMP("PXRMGEC_CK1",$J,I,J),"^",5) I USER'="" S USER=$P(^VA(200,USER,0),"^",1)
  1.  ...S DATE=$P(^TMP("PXRMGEC_CK1",$J,I,J),"^",6) I DATE'="" S DATE=$$FMTE^XLFDT(DATE,"1P")
  1.  ...I J=1 W !,$O(^TMP("PXRMGEC_CK1",$J,0)),?10,STAMP_" (start date)"
  1.  ...W !,?15,DIALOG,?35,"  by: ",USER," ",?62," On: ",DATE
  1.  ;
  1.  W !!,?5,"Historical Referral(s)::"
  1.  I $P(STATUS,"^",2)=0 D
  1.  .W !,?10,"< N O N E >"
  1.  I $P(STATUS,"^",2)=1 D
  1.  .N J,K,STAMP,STAMPB,DIALOG,USER,DATE,I,DAX,COUNT
  1.  .S STAMPB=1,J=1,K=0,COUNT=$S($D(LOOP):5,1:0)
  1.  .S I=1 F  S I=$O(^TMP("PXRMGEC_CK2",$J,I)),COUNT=COUNT+1 Q:I=""  Q:COUNT=3  D
  1.  ..W !
  1.  ..S K=0 F  S K=$O(^TMP("PXRMGEC_CK2",$J,I,K)) Q:K=""  D
  1.  ...S DAX=0 F  S DAX=$O(^TMP("PXRMGEC_CK2",$J,I,K,DAX)) Q:DAX=""  D
  1.  ....S STAMP=$P(^TMP("PXRMGEC_CK2",$J,I,K,DAX),"^",2)
  1.  ....I STAMP'=STAMPB S J=J+1,CNT=I
  1.  ....S CNTA=$O(^TMP("PXRMGEC_CK2",$J,0)),CNTB=CNTA+2
  1.  ....S STAMP=$$FMTE^XLFDT(STAMP,"1P")
  1.  ....S DIALOG=$$DIALOG($P(^TMP("PXRMGEC_CK2",$J,I,K,DAX),"^",3))
  1.  ....S USER=$P(^TMP("PXRMGEC_CK2",$J,I,K,DAX),"^",5) I USER'="" S USER=$P(^VA(200,USER,0),"^",1)
  1.  ....S DATE=$P(^TMP("PXRMGEC_CK2",$J,I,K,DAX),"^",6) I DATE'="" S DATE=$$FMTE^XLFDT(DATE,"1P")
  1.  ....I STAMP'=STAMPB W !,I,?10,STAMP_" (start date)"
  1.  ....W !,?15,DIALOG," ",?35,"  by: ",USER," ",?62," On: ",DATE
  1.  ....S STAMPB=STAMP
  1.  ;
  1. ASK ;Ask the User what they want to do.
  1.  N DIR,Y,X,MODE,ROPNNUM
  1.  K DIR(0),DIR("A")
  1.  I STATUS="0^1",CNT=2,'$D(LOOP) S DIR(0)="S^R:Re-open 1 Referral;V:View All Historical Referrals;P:New Patient;Q:Quit"
  1.  I STATUS="0^1",CNT=2,$D(LOOP) S DIR(0)="S^R:Re-open 1 Referral;D:Display Last 2 Referrals Only;P:New Patient;Q:Quit"
  1.  I STATUS="0^1",CNT>2,'$D(LOOP) S DIR(0)="S^R:Re-open 1 Referral;M:Merge 2 Referrals;V:View All Historical Referrals;P:New Patient;Q:Quit"
  1.  I STATUS="0^1",CNT>2,$D(LOOP) S DIR(0)="S^R:Re-open 1 Referral;M:Merge 2 Referrals;D:Display Last 2 Referrals Only;P:New Patient;Q:Quit"
  1.  I STATUS="1^1",'$D(LOOP) S DIR(0)="S^C:CLOSE Open Referral;M:Merge 2 Referrals;V:View ALL Historical Referrals;P:New Patient;Q:Quit"
  1.  I STATUS="1^1",$D(LOOP) S DIR(0)="S^C:CLOSE Open Referral;M:Merge 2 Referrals;D:Display Last 2 Referrals Only;P:New Patient;Q:Quit"
  1.  I STATUS="1^0"!(STATUS="0^0") S DIR(0)="S^C:CLOSE Open Referral;P:New Patient;Q:Quit"
  1.  D ^DIR S MODE=Y W !
  1.  I MODE="R" D
  1.  .S DIR(0)="NO^"_$O(^TMP("PXRMGEC_CK2",$J,0))_":"_CNT_":0"
  1.  .S DIR("A")="Enter the number on the Left side of the screen next to the Historical Referral that you want to re-open."
  1.  .D ^DIR
  1.  .S ROPNNUM=Y
  1.  I MODE="M" D  I $D(DIRUT) G ASK
  1. MRG .I STATUS="0^1" S DIR(0)="NO^"_CNTA_":"_$S($D(LOOP):CNT,1:CNTB)_":0"
  1.  .I STATUS="1^1" S DIR(0)="NO^"_$O(^TMP("PXRMGEC_CK1",$J,0))_":"_CNT_":0"
  1.  .S DIR("A")="First Referral Record"
  1.  .D ^DIR Q:$D(DIRUT)  S FIRST=Y D  Q:$D(DIRUT)
  1.  ..I STATUS="0^1" S DIR(0)="NO^"_CNTA_":"_$S($D(LOOP):CNT,1:CNTB)_":0"
  1.  ..I STATUS="1^1" S DIR(0)="NO^"_$O(^TMP("PXRMGEC_CK1",$J,0))_":"_CNT_":0"
  1.  ..S DIR("A")="Second Referral Record"
  1.  ..D ^DIR Q:$D(DIRUT)  S SECOND=Y
  1.  .I +FIRST>0,+SECOND>0,FIRST=SECOND W !,"Try again.." G MRG
  1.  I MODE="Q" D EXIT
  1.  I MODE="R" D REOPEN^PXRMGECL(ROPNNUM) G DISP
  1.  I MODE="M" D MERGE(FIRST,SECOND,DFN) G DISP
  1.  I MODE="V" S LOOP=1 G DISP
  1.  I MODE="D" K LOOP G DISP
  1.  I MODE="P" G EN
  1.  I MODE="C" D FINISHED^PXRMGECU(DFN,1) G DISP
  1.  Q
  1.  ;
  1. MERGE(FIR,SEC,DFN) ;Merge 2 Referrals
  1.  Q:FIR=""
  1.  Q:SEC=""
  1.  Q:DFN=""
  1.  N DATE1,DATE2,OLDDT,OLD,SRCHDT
  1.  W !,"DO MERGE",!
  1.  ;Get Date to use for setting and to be changed.
  1.  I $D(^TMP("PXRMGEC_CK1",$J,FIR,1)) S DATE(FIR)=$P($G(^TMP("PXRMGEC_CK1",$J,FIR,1)),"^",2)
  1.  I $D(^TMP("PXRMGEC_CK1",$J,SEC,1)) S DATE(SEC)=$P($G(^TMP("PXRMGEC_CK1",$J,SEC,1)),"^",2)
  1.  I $D(^TMP("PXRMGEC_CK2",$J,FIR)) D
  1.  .N SUB3,SUBDA
  1.  .S SUB3=$O(^TMP("PXRMGEC_CK2",$J,FIR,0))
  1.  .S SUBDA=$O(^TMP("PXRMGEC_CK2",$J,FIR,SUB3,0))
  1.  .S DATE(FIR)=$P($G(^TMP("PXRMGEC_CK2",$J,FIR,SUB3,SUBDA)),"^",2)
  1.  I $D(^TMP("PXRMGEC_CK2",$J,SEC)) D
  1.  .N SUB3,SUBDA
  1.  .S SUB3=$O(^TMP("PXRMGEC_CK2",$J,SEC,0))
  1.  .S SUBDA=$O(^TMP("PXRMGEC_CK2",$J,SEC,SUB3,0))
  1.  .S DATE(SEC)=$P($G(^TMP("PXRMGEC_CK2",$J,SEC,SUB3,SUBDA)),"^",2)
  1.  S OLD(DATE(FIR))=FIR
  1.  S OLD(DATE(SEC))=SEC
  1.  S OLDDT=$O(OLD(0))
  1.  S SRCHDT=$O(OLD(OLDDT))
  1.  ;
  1.  ;List of Health Factors DA's to change
  1.  N DATE,ARY,GEC,DA,VISIT,ROOT,PKG,SOURCE
  1.  N HF0,HF12,HF801,HF812,ARY1
  1.  S ARY="^AUPNVHF(""AED"","_SRCHDT_","_DFN_")"
  1.  S GEC="" F  S GEC=$O(@ARY@(GEC)) Q:GEC=""  D
  1.  .S DA=0 F  S DA=$O(@ARY@(GEC,DA)) Q:DA=""  D
  1.  ..S VISIT=$P($G(^AUPNVHF(DA,0)),"^",3)
  1.  ..S ^TMP("PXRMGECMRG",$J,VISIT,DA,SRCHDT)=""
  1.  ;
  1.  ;Change HF with DATA2PCE
  1.  S I=0
  1.  S ROOT="^TMP(""PXRMGECMRGPCE"",$J)"
  1.  S SOURCE="Geriatric Extended Care Merge"
  1.  ;
  1.  S ARY1="^TMP(""PXRMGECMRG"",$J)"
  1.  S VISIT=0 F  S VISIT=$O(@ARY1@(VISIT)) Q:VISIT=""  D
  1.  .S DA=0 F  S DA=$O(@ARY1@(VISIT,DA)) Q:DA=""  D
  1.  ..I $D(^AUPNVHF(DA)) D
  1.  ...S HF0=$G(^AUPNVHF(DA,0))
  1.  ...S HF12=$G(^AUPNVHF(DA,12))
  1.  ...S HF812=$G(^AUPNVHF(DA,812))
  1.  ...;
  1.  ...S PKG=$P(HF812,"^",2)
  1.  ...S SOURCE=$P(HF812,"^",3)
  1.  ...S USER=DUZ
  1.  ...S @ROOT@("HEALTH FACTOR",DA,"HEALTH FACTOR")=$P(HF0,"^",1)
  1.  ...S @ROOT@("HEALTH FACTOR",DA,"LEVEL/SEVERITY")=$P(HF0,"^",4)
  1.  ...S @ROOT@("HEALTH FACTOR",DA,"ENC PROVIDER")=$P(HF12,"^",4)
  1.  ...S @ROOT@("HEALTH FACTOR",DA,"EVENT D/T")=OLDDT
  1.  .I $D(^TMP("PXRMGECMRGPCE",$J)) D
  1.  ..N NOEVT
  1.  ..S NOEVT="PXKNOEVT"
  1.  ..S @NOEVT=1
  1.  ..S OK=$$DATA2PCE^PXAPI(ROOT,PKG,SOURCE,.VISIT,USER,"","","")
  1.  ;
  1.  ;Change 801.55
  1.  N GEC,DA,GECX,GECM
  1.  ;
  1.  S GEC="" F  S GEC=$O(^PXRMD(801.55,"AC",DFN,SRCHDT,GEC)) Q:GEC=""  D
  1.  .S DA=0 F  S DA=$O(^PXRMD(801.55,"AC",DFN,SRCHDT,GEC,DA)) Q:DA=""  D
  1.  ..S GECX(1,801.55,DA_",",.02)=OLDDT
  1.  ..D FILE^DIE("","GECX(1)") K GECX
  1.  ..;
  1.  ..I FIR=$O(^TMP("PXRMGEC_CK1",$J,0)) D
  1.  ...;I FIR=1!(SEC=1) D
  1.  ...I '$D(^PXRMD(801.5,"AC",DFN,SRCHDT,GEC)) D
  1.  ....S GECM(1,801.5,"+1,",.01)=$P($G(^PXRMD(801.55,DA,0)),"^",1)
  1.  ....S GECM(1,801.5,"+1,",.02)=$P($G(^PXRMD(801.55,DA,0)),"^",2)
  1.  ....S GECM(1,801.5,"+1,",.03)=$P($G(^PXRMD(801.55,DA,0)),"^",3)
  1.  ....S GECM(1,801.5,"+1,",.04)=$P($G(^PXRMD(801.55,DA,0)),"^",4)
  1.  ....S GECM(1,801.5,"+1,",.05)=$P($G(^PXRMD(801.55,DA,0)),"^",5)
  1.  ....S GECM(1,801.5,"+1,",.06)=$P($G(^PXRMD(801.55,DA,0)),"^",6)
  1.  ....D UPDATE^DIE("","GECM(1)")
  1.  ;
  1.  ;
  1.  ;Change 801.5
  1.  N GEC,DA,GECX
  1.  ;
  1.  S GEC="" F  S GEC=$O(^PXRMD(801.5,"AC",DFN,SRCHDT,GEC)) Q:GEC=""  D
  1.  .S DA=0 F  S DA=$O(^PXRMD(801.5,"AC",DFN,SRCHDT,GEC,DA)) Q:DA=""  D
  1.  ..S GECX(1,801.5,DA_",",.02)=OLDDT
  1.  ..D FILE^DIE("","GECX(1)") K GECX
  1.  ;EXIT
  1.  K ^TMP("PXRMGECMRG",$J)
  1.  K ^TMP("PXRMGECMRGPCE",$J)
  1.  Q
  1.  ;
  1.  ;
  1. PAT ;LOOK UP ALL PATIENTS
  1.  W @IOF,!
  1.  S DIR(0)="801.55,.01"
  1.  D ^DIR
  1.  S DFN=+Y
  1.  K Y,Y(0),Y(0,0)
  1.  Q
  1.  ;
  1. CK1(DFN) ;Check for current open referral
  1.  Q:DFN'>0
  1.  N STATUS,I,Z
  1.  K ^TMP("PXRMGEC_CK1",$J)
  1.  S STATUS=0,I=1,J=0
  1.  ;S Z=$$CK2(DFN) S I=$O(^TMP("PXRMGEC_CK2",$J,0))-1
  1.  I $D(^PXRMD(801.5,"B",DFN)) D
  1.  .S DA=0 F  S DA=$O(^PXRMD(801.5,"B",DFN,DA)) Q:DA=""  S J=J+1 D
  1.  ..S ^TMP("PXRMGEC_CK1",$J,I,J)=$G(^PXRMD(801.5,DA,0))
  1.  .S STATUS=1
  1.  Q STATUS
  1.  ;
  1. CK2(DFN) ;Check for entries in History file 801.55
  1.  Q:DFN'>0
  1.  N STATUS,I,CURRENT,DATE,DIA,DA,J
  1.  K ^TMP("PXRMGEC_CK2",$J)
  1.  S STATUS=0,I=1000,J=0
  1.  I $D(^TMP("PXRMGEC_CK1",$J)) S CURRENT=$P($G(^TMP("PXRMGEC_CK1",$J,$O(^TMP("PXRMGEC_CK1",$J,0)),1)),"^",2)
  1.  I $D(^PXRMD(801.55,"B",DFN)) D
  1.  .S DATE="" F  S DATE=$O(^PXRMD(801.55,"AC",DFN,DATE)) Q:DATE=""  D
  1.  ..Q:$G(CURRENT)=DATE
  1.  ..S I=I-1
  1.  ..S DIA="" F  S DIA=$O(^PXRMD(801.55,"AC",DFN,DATE,DIA)) Q:DIA=""  D
  1.  ...S J=J+1
  1.  ...S DA=0 F  S DA=$O(^PXRMD(801.55,"AC",DFN,DATE,DIA,DA)) Q:DA=""  D
  1.  ....S ^TMP("PXRMGEC_CK2",$J,I,J,DA)=$G(^PXRMD(801.55,DA,0))
  1.  ....S STATUS=1
  1.  ;RENUMBER ARRAY
  1.  I $D(^TMP("PXRMGEC_CK2",$J)) D
  1.  .N OLD,NEW,J,DA,DATA
  1.  .S NEW=1
  1.  .S OLD=0 F  S OLD=$O(^TMP("PXRMGEC_CK2",$J,OLD)) Q:OLD=""  D
  1.  ..S NEW=NEW+1
  1.  ..S J=0 F  S J=$O(^TMP("PXRMGEC_CK2",$J,OLD,J)) Q:J=""  D
  1.  ...S DA=0 F  S DA=$O(^TMP("PXRMGEC_CK2",$J,OLD,J,DA)) Q:DA=""  D
  1.  ....S DATA=$G(^TMP("PXRMGEC_CK2",$J,OLD,J,DA))
  1.  ....S ^TMP("PXRMGEC_CK2",$J,NEW,J,DA)=DATA
  1.  ....K ^TMP("PXRMGEC_CK2",$J,OLD,J,DA)
  1.  Q STATUS
  1.  ;
  1. DIALOG(DIA) ;Returns expanded name of dialog
  1.  N NAME
  1.  S NAME=""
  1.  I DIA="GEC1" S NAME="Social Services"
  1.  I DIA="GEC2" S NAME="Nursing Assessment"
  1.  I DIA="GEC3" S NAME="Care Recommendation"
  1.  I DIA="GECF" S NAME="Care Coordination"
  1.  Q NAME
  1.  ;
  1. EXIT ;CLEAN UP
  1.  K CK2,LOOP,X,CNTA,CNTB,ROPNNUM
  1.  K ^TMP("PXRMGEC_CK1",$J),^TMP("PXRMGEC_CK2",$J)
  1.  Q
  1.  ;