PXRMGECJ ;SLC/AGP,JVS - Restore Func ;7/14/05 10:42
;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
;Restore GEC Referral to open status
Q
;
EN ;Starting point
N DIR,DA,DFN,STATUS,NAME,STAMP,CNT,FIRST,SECOND,DIRUT
K ^TMP("PXRMGEC_CK1",$J),DIR(0),^TMP("PXRMGEC_CK2",$J)
D PAT
I $D(DIRUT) Q
;
DISP ;Display referrals and data
N LOC,DIV,SSN,AGE
S NAME=$P(^DPT(DFN,0),"^",1)
S LOC=$S($D(^DPT(DFN,.1)):"INPATIENT",1:"OUTPATIENT")
S DIV=$$GET1^DIQ(2,DFN,.19) I DIV="" S DIV="Unknown"
S SSN=$$GET1^DIQ(2,DFN,.09)
S AGE=$$GET1^DIQ(2,DFN,.033)
S STATUS=$$CK1(DFN)_"^"_$$CK2(DFN)
;
;
W !,"================================================================================"
W !,NAME," (",SSN,") "," AGE:",AGE," ",LOC," ",DIV," Division",!
W !,?5,"Current Open Referral::"
I +STATUS=0 W !,?10,"< N O N E >"
I +STATUS=1 D
.N I,DATE,DIALOG,USER,STAMP
.S I=0 F S I=$O(^TMP("PXRMGEC_CK1",$J,I)) Q:I="" D
..S J=0 F S J=$O(^TMP("PXRMGEC_CK1",$J,I,J)) Q:J="" D
...S STAMP=$P(^TMP("PXRMGEC_CK1",$J,I,J),"^",2) I STAMP'="" S STAMP=$$FMTE^XLFDT(STAMP,"1P")
...S DIALOG=$$DIALOG($P(^TMP("PXRMGEC_CK1",$J,I,J),"^",3))
...S USER=$P(^TMP("PXRMGEC_CK1",$J,I,J),"^",5) I USER'="" S USER=$P(^VA(200,USER,0),"^",1)
...S DATE=$P(^TMP("PXRMGEC_CK1",$J,I,J),"^",6) I DATE'="" S DATE=$$FMTE^XLFDT(DATE,"1P")
...I J=1 W !,$O(^TMP("PXRMGEC_CK1",$J,0)),?10,STAMP_" (start date)"
...W !,?15,DIALOG,?35," by: ",USER," ",?62," On: ",DATE
;
W !!,?5,"Historical Referral(s)::"
I $P(STATUS,"^",2)=0 D
.W !,?10,"< N O N E >"
I $P(STATUS,"^",2)=1 D
.N J,K,STAMP,STAMPB,DIALOG,USER,DATE,I,DAX,COUNT
.S STAMPB=1,J=1,K=0,COUNT=$S($D(LOOP):5,1:0)
.S I=1 F S I=$O(^TMP("PXRMGEC_CK2",$J,I)),COUNT=COUNT+1 Q:I="" Q:COUNT=3 D
..W !
..S K=0 F S K=$O(^TMP("PXRMGEC_CK2",$J,I,K)) Q:K="" D
...S DAX=0 F S DAX=$O(^TMP("PXRMGEC_CK2",$J,I,K,DAX)) Q:DAX="" D
....S STAMP=$P(^TMP("PXRMGEC_CK2",$J,I,K,DAX),"^",2)
....I STAMP'=STAMPB S J=J+1,CNT=I
....S CNTA=$O(^TMP("PXRMGEC_CK2",$J,0)),CNTB=CNTA+2
....S STAMP=$$FMTE^XLFDT(STAMP,"1P")
....S DIALOG=$$DIALOG($P(^TMP("PXRMGEC_CK2",$J,I,K,DAX),"^",3))
....S USER=$P(^TMP("PXRMGEC_CK2",$J,I,K,DAX),"^",5) I USER'="" S USER=$P(^VA(200,USER,0),"^",1)
....S DATE=$P(^TMP("PXRMGEC_CK2",$J,I,K,DAX),"^",6) I DATE'="" S DATE=$$FMTE^XLFDT(DATE,"1P")
....I STAMP'=STAMPB W !,I,?10,STAMP_" (start date)"
....W !,?15,DIALOG," ",?35," by: ",USER," ",?62," On: ",DATE
....S STAMPB=STAMP
;
ASK ;Ask the User what they want to do.
N DIR,Y,X,MODE,ROPNNUM
K DIR(0),DIR("A")
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"
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"
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"
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"
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"
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"
I STATUS="1^0"!(STATUS="0^0") S DIR(0)="S^C:CLOSE Open Referral;P:New Patient;Q:Quit"
D ^DIR S MODE=Y W !
I MODE="R" D
.S DIR(0)="NO^"_$O(^TMP("PXRMGEC_CK2",$J,0))_":"_CNT_":0"
.S DIR("A")="Enter the number on the Left side of the screen next to the Historical Referral that you want to re-open."
.D ^DIR
.S ROPNNUM=Y
I MODE="M" D I $D(DIRUT) G ASK
MRG .I STATUS="0^1" S DIR(0)="NO^"_CNTA_":"_$S($D(LOOP):CNT,1:CNTB)_":0"
.I STATUS="1^1" S DIR(0)="NO^"_$O(^TMP("PXRMGEC_CK1",$J,0))_":"_CNT_":0"
.S DIR("A")="First Referral Record"
.D ^DIR Q:$D(DIRUT) S FIRST=Y D Q:$D(DIRUT)
..I STATUS="0^1" S DIR(0)="NO^"_CNTA_":"_$S($D(LOOP):CNT,1:CNTB)_":0"
..I STATUS="1^1" S DIR(0)="NO^"_$O(^TMP("PXRMGEC_CK1",$J,0))_":"_CNT_":0"
..S DIR("A")="Second Referral Record"
..D ^DIR Q:$D(DIRUT) S SECOND=Y
.I +FIRST>0,+SECOND>0,FIRST=SECOND W !,"Try again.." G MRG
I MODE="Q" D EXIT
I MODE="R" D REOPEN^PXRMGECL(ROPNNUM) G DISP
I MODE="M" D MERGE(FIRST,SECOND,DFN) G DISP
I MODE="V" S LOOP=1 G DISP
I MODE="D" K LOOP G DISP
I MODE="P" G EN
I MODE="C" D FINISHED^PXRMGECU(DFN,1) G DISP
Q
;
MERGE(FIR,SEC,DFN) ;Merge 2 Referrals
Q:FIR=""
Q:SEC=""
Q:DFN=""
N DATE1,DATE2,OLDDT,OLD,SRCHDT
W !,"DO MERGE",!
;Get Date to use for setting and to be changed.
I $D(^TMP("PXRMGEC_CK1",$J,FIR,1)) S DATE(FIR)=$P($G(^TMP("PXRMGEC_CK1",$J,FIR,1)),"^",2)
I $D(^TMP("PXRMGEC_CK1",$J,SEC,1)) S DATE(SEC)=$P($G(^TMP("PXRMGEC_CK1",$J,SEC,1)),"^",2)
I $D(^TMP("PXRMGEC_CK2",$J,FIR)) D
.N SUB3,SUBDA
.S SUB3=$O(^TMP("PXRMGEC_CK2",$J,FIR,0))
.S SUBDA=$O(^TMP("PXRMGEC_CK2",$J,FIR,SUB3,0))
.S DATE(FIR)=$P($G(^TMP("PXRMGEC_CK2",$J,FIR,SUB3,SUBDA)),"^",2)
I $D(^TMP("PXRMGEC_CK2",$J,SEC)) D
.N SUB3,SUBDA
.S SUB3=$O(^TMP("PXRMGEC_CK2",$J,SEC,0))
.S SUBDA=$O(^TMP("PXRMGEC_CK2",$J,SEC,SUB3,0))
.S DATE(SEC)=$P($G(^TMP("PXRMGEC_CK2",$J,SEC,SUB3,SUBDA)),"^",2)
S OLD(DATE(FIR))=FIR
S OLD(DATE(SEC))=SEC
S OLDDT=$O(OLD(0))
S SRCHDT=$O(OLD(OLDDT))
;
;List of Health Factors DA's to change
N DATE,ARY,GEC,DA,VISIT,ROOT,PKG,SOURCE
N HF0,HF12,HF801,HF812,ARY1
S ARY="^AUPNVHF(""AED"","_SRCHDT_","_DFN_")"
S GEC="" F S GEC=$O(@ARY@(GEC)) Q:GEC="" D
.S DA=0 F S DA=$O(@ARY@(GEC,DA)) Q:DA="" D
..S VISIT=$P($G(^AUPNVHF(DA,0)),"^",3)
..S ^TMP("PXRMGECMRG",$J,VISIT,DA,SRCHDT)=""
;
;Change HF with DATA2PCE
S I=0
S ROOT="^TMP(""PXRMGECMRGPCE"",$J)"
S SOURCE="Geriatric Extended Care Merge"
;
S ARY1="^TMP(""PXRMGECMRG"",$J)"
S VISIT=0 F S VISIT=$O(@ARY1@(VISIT)) Q:VISIT="" D
.S DA=0 F S DA=$O(@ARY1@(VISIT,DA)) Q:DA="" D
..I $D(^AUPNVHF(DA)) D
...S HF0=$G(^AUPNVHF(DA,0))
...S HF12=$G(^AUPNVHF(DA,12))
...S HF812=$G(^AUPNVHF(DA,812))
...;
...S PKG=$P(HF812,"^",2)
...S SOURCE=$P(HF812,"^",3)
...S USER=DUZ
...S @ROOT@("HEALTH FACTOR",DA,"HEALTH FACTOR")=$P(HF0,"^",1)
...S @ROOT@("HEALTH FACTOR",DA,"LEVEL/SEVERITY")=$P(HF0,"^",4)
...S @ROOT@("HEALTH FACTOR",DA,"ENC PROVIDER")=$P(HF12,"^",4)
...S @ROOT@("HEALTH FACTOR",DA,"EVENT D/T")=OLDDT
.I $D(^TMP("PXRMGECMRGPCE",$J)) D
..N NOEVT
..S NOEVT="PXKNOEVT"
..S @NOEVT=1
..S OK=$$DATA2PCE^PXAPI(ROOT,PKG,SOURCE,.VISIT,USER,"","","")
;
;Change 801.55
N GEC,DA,GECX,GECM
;
S GEC="" F S GEC=$O(^PXRMD(801.55,"AC",DFN,SRCHDT,GEC)) Q:GEC="" D
.S DA=0 F S DA=$O(^PXRMD(801.55,"AC",DFN,SRCHDT,GEC,DA)) Q:DA="" D
..S GECX(1,801.55,DA_",",.02)=OLDDT
..D FILE^DIE("","GECX(1)") K GECX
..;
..I FIR=$O(^TMP("PXRMGEC_CK1",$J,0)) D
...;I FIR=1!(SEC=1) D
...I '$D(^PXRMD(801.5,"AC",DFN,SRCHDT,GEC)) D
....S GECM(1,801.5,"+1,",.01)=$P($G(^PXRMD(801.55,DA,0)),"^",1)
....S GECM(1,801.5,"+1,",.02)=$P($G(^PXRMD(801.55,DA,0)),"^",2)
....S GECM(1,801.5,"+1,",.03)=$P($G(^PXRMD(801.55,DA,0)),"^",3)
....S GECM(1,801.5,"+1,",.04)=$P($G(^PXRMD(801.55,DA,0)),"^",4)
....S GECM(1,801.5,"+1,",.05)=$P($G(^PXRMD(801.55,DA,0)),"^",5)
....S GECM(1,801.5,"+1,",.06)=$P($G(^PXRMD(801.55,DA,0)),"^",6)
....D UPDATE^DIE("","GECM(1)")
;
;
;Change 801.5
N GEC,DA,GECX
;
S GEC="" F S GEC=$O(^PXRMD(801.5,"AC",DFN,SRCHDT,GEC)) Q:GEC="" D
.S DA=0 F S DA=$O(^PXRMD(801.5,"AC",DFN,SRCHDT,GEC,DA)) Q:DA="" D
..S GECX(1,801.5,DA_",",.02)=OLDDT
..D FILE^DIE("","GECX(1)") K GECX
;EXIT
K ^TMP("PXRMGECMRG",$J)
K ^TMP("PXRMGECMRGPCE",$J)
Q
;
;
PAT ;LOOK UP ALL PATIENTS
W @IOF,!
S DIR(0)="801.55,.01"
D ^DIR
S DFN=+Y
K Y,Y(0),Y(0,0)
Q
;
CK1(DFN) ;Check for current open referral
Q:DFN'>0
N STATUS,I,Z
K ^TMP("PXRMGEC_CK1",$J)
S STATUS=0,I=1,J=0
;S Z=$$CK2(DFN) S I=$O(^TMP("PXRMGEC_CK2",$J,0))-1
I $D(^PXRMD(801.5,"B",DFN)) D
.S DA=0 F S DA=$O(^PXRMD(801.5,"B",DFN,DA)) Q:DA="" S J=J+1 D
..S ^TMP("PXRMGEC_CK1",$J,I,J)=$G(^PXRMD(801.5,DA,0))
.S STATUS=1
Q STATUS
;
CK2(DFN) ;Check for entries in History file 801.55
Q:DFN'>0
N STATUS,I,CURRENT,DATE,DIA,DA,J
K ^TMP("PXRMGEC_CK2",$J)
S STATUS=0,I=1000,J=0
I $D(^TMP("PXRMGEC_CK1",$J)) S CURRENT=$P($G(^TMP("PXRMGEC_CK1",$J,$O(^TMP("PXRMGEC_CK1",$J,0)),1)),"^",2)
I $D(^PXRMD(801.55,"B",DFN)) D
.S DATE="" F S DATE=$O(^PXRMD(801.55,"AC",DFN,DATE)) Q:DATE="" D
..Q:$G(CURRENT)=DATE
..S I=I-1
..S DIA="" F S DIA=$O(^PXRMD(801.55,"AC",DFN,DATE,DIA)) Q:DIA="" D
...S J=J+1
...S DA=0 F S DA=$O(^PXRMD(801.55,"AC",DFN,DATE,DIA,DA)) Q:DA="" D
....S ^TMP("PXRMGEC_CK2",$J,I,J,DA)=$G(^PXRMD(801.55,DA,0))
....S STATUS=1
;RENUMBER ARRAY
I $D(^TMP("PXRMGEC_CK2",$J)) D
.N OLD,NEW,J,DA,DATA
.S NEW=1
.S OLD=0 F S OLD=$O(^TMP("PXRMGEC_CK2",$J,OLD)) Q:OLD="" D
..S NEW=NEW+1
..S J=0 F S J=$O(^TMP("PXRMGEC_CK2",$J,OLD,J)) Q:J="" D
...S DA=0 F S DA=$O(^TMP("PXRMGEC_CK2",$J,OLD,J,DA)) Q:DA="" D
....S DATA=$G(^TMP("PXRMGEC_CK2",$J,OLD,J,DA))
....S ^TMP("PXRMGEC_CK2",$J,NEW,J,DA)=DATA
....K ^TMP("PXRMGEC_CK2",$J,OLD,J,DA)
Q STATUS
;
DIALOG(DIA) ;Returns expanded name of dialog
N NAME
S NAME=""
I DIA="GEC1" S NAME="Social Services"
I DIA="GEC2" S NAME="Nursing Assessment"
I DIA="GEC3" S NAME="Care Recommendation"
I DIA="GECF" S NAME="Care Coordination"
Q NAME
;
EXIT ;CLEAN UP
K CK2,LOOP,X,CNTA,CNTB,ROPNNUM
K ^TMP("PXRMGEC_CK1",$J),^TMP("PXRMGEC_CK2",$J)
Q
;
PXRMGECJ ;SLC/AGP,JVS - Restore Func ;7/14/05 10:42
+1 ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+2 ;Restore GEC Referral to open status
+3 QUIT
+4 ;
EN ;Starting point
+1 NEW DIR,DA,DFN,STATUS,NAME,STAMP,CNT,FIRST,SECOND,DIRUT
+2 KILL ^TMP("PXRMGEC_CK1",$JOB),DIR(0),^TMP("PXRMGEC_CK2",$JOB)
+3 DO PAT
+4 IF $DATA(DIRUT)
QUIT
+5 ;
DISP ;Display referrals and data
+1 NEW LOC,DIV,SSN,AGE
+2 SET NAME=$PIECE(^DPT(DFN,0),"^",1)
+3 SET LOC=$SELECT($DATA(^DPT(DFN,.1)):"INPATIENT",1:"OUTPATIENT")
+4 SET DIV=$$GET1^DIQ(2,DFN,.19)
IF DIV=""
SET DIV="Unknown"
+5 SET SSN=$$GET1^DIQ(2,DFN,.09)
+6 SET AGE=$$GET1^DIQ(2,DFN,.033)
+7 SET STATUS=$$CK1(DFN)_"^"_$$CK2(DFN)
+8 ;
+9 ;
+10 WRITE !,"================================================================================"
+11 WRITE !,NAME," (",SSN,") "," AGE:",AGE," ",LOC," ",DIV," Division",!
+12 WRITE !,?5,"Current Open Referral::"
+13 IF +STATUS=0
WRITE !,?10,"< N O N E >"
+14 IF +STATUS=1
Begin DoDot:1
+15 NEW I,DATE,DIALOG,USER,STAMP
+16 SET I=0
FOR
SET I=$ORDER(^TMP("PXRMGEC_CK1",$JOB,I))
IF I=""
QUIT
Begin DoDot:2
+17 SET J=0
FOR
SET J=$ORDER(^TMP("PXRMGEC_CK1",$JOB,I,J))
IF J=""
QUIT
Begin DoDot:3
+18 SET STAMP=$PIECE(^TMP("PXRMGEC_CK1",$JOB,I,J),"^",2)
IF STAMP'=""
SET STAMP=$$FMTE^XLFDT(STAMP,"1P")
+19 SET DIALOG=$$DIALOG($PIECE(^TMP("PXRMGEC_CK1",$JOB,I,J),"^",3))
+20 SET USER=$PIECE(^TMP("PXRMGEC_CK1",$JOB,I,J),"^",5)
IF USER'=""
SET USER=$PIECE(^VA(200,USER,0),"^",1)
+21 SET DATE=$PIECE(^TMP("PXRMGEC_CK1",$JOB,I,J),"^",6)
IF DATE'=""
SET DATE=$$FMTE^XLFDT(DATE,"1P")
+22 IF J=1
WRITE !,$ORDER(^TMP("PXRMGEC_CK1",$JOB,0)),?10,STAMP_" (start date)"
+23 WRITE !,?15,DIALOG,?35," by: ",USER," ",?62," On: ",DATE
End DoDot:3
End DoDot:2
End DoDot:1
+24 ;
+25 WRITE !!,?5,"Historical Referral(s)::"
+26 IF $PIECE(STATUS,"^",2)=0
Begin DoDot:1
+27 WRITE !,?10,"< N O N E >"
End DoDot:1
+28 IF $PIECE(STATUS,"^",2)=1
Begin DoDot:1
+29 NEW J,K,STAMP,STAMPB,DIALOG,USER,DATE,I,DAX,COUNT
+30 SET STAMPB=1
SET J=1
SET K=0
SET COUNT=$SELECT($DATA(LOOP):5,1:0)
+31 SET I=1
FOR
SET I=$ORDER(^TMP("PXRMGEC_CK2",$JOB,I))
SET COUNT=COUNT+1
IF I=""
QUIT
IF COUNT=3
QUIT
Begin DoDot:2
+32 WRITE !
+33 SET K=0
FOR
SET K=$ORDER(^TMP("PXRMGEC_CK2",$JOB,I,K))
IF K=""
QUIT
Begin DoDot:3
+34 SET DAX=0
FOR
SET DAX=$ORDER(^TMP("PXRMGEC_CK2",$JOB,I,K,DAX))
IF DAX=""
QUIT
Begin DoDot:4
+35 SET STAMP=$PIECE(^TMP("PXRMGEC_CK2",$JOB,I,K,DAX),"^",2)
+36 IF STAMP'=STAMPB
SET J=J+1
SET CNT=I
+37 SET CNTA=$ORDER(^TMP("PXRMGEC_CK2",$JOB,0))
SET CNTB=CNTA+2
+38 SET STAMP=$$FMTE^XLFDT(STAMP,"1P")
+39 SET DIALOG=$$DIALOG($PIECE(^TMP("PXRMGEC_CK2",$JOB,I,K,DAX),"^",3))
+40 SET USER=$PIECE(^TMP("PXRMGEC_CK2",$JOB,I,K,DAX),"^",5)
IF USER'=""
SET USER=$PIECE(^VA(200,USER,0),"^",1)
+41 SET DATE=$PIECE(^TMP("PXRMGEC_CK2",$JOB,I,K,DAX),"^",6)
IF DATE'=""
SET DATE=$$FMTE^XLFDT(DATE,"1P")
+42 IF STAMP'=STAMPB
WRITE !,I,?10,STAMP_" (start date)"
+43 WRITE !,?15,DIALOG," ",?35," by: ",USER," ",?62," On: ",DATE
+44 SET STAMPB=STAMP
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+45 ;
ASK ;Ask the User what they want to do.
+1 NEW DIR,Y,X,MODE,ROPNNUM
+2 KILL DIR(0),DIR("A")
+3 IF STATUS="0^1"
IF CNT=2
IF '$DATA(LOOP)
SET DIR(0)="S^R:Re-open 1 Referral;V:View All Historical Referrals;P:New Patient;Q:Quit"
+4 IF STATUS="0^1"
IF CNT=2
IF $DATA(LOOP)
SET DIR(0)="S^R:Re-open 1 Referral;D:Display Last 2 Referrals Only;P:New Patient;Q:Quit"
+5 IF STATUS="0^1"
IF CNT>2
IF '$DATA(LOOP)
SET DIR(0)="S^R:Re-open 1 Referral;M:Merge 2 Referrals;V:View All Historical Referrals;P:New Patient;Q:Quit"
+6 IF STATUS="0^1"
IF CNT>2
IF $DATA(LOOP)
SET DIR(0)="S^R:Re-open 1 Referral;M:Merge 2 Referrals;D:Display Last 2 Referrals Only;P:New Patient;Q:Quit"
+7 IF STATUS="1^1"
IF '$DATA(LOOP)
SET DIR(0)="S^C:CLOSE Open Referral;M:Merge 2 Referrals;V:View ALL Historical Referrals;P:New Patient;Q:Quit"
+8 IF STATUS="1^1"
IF $DATA(LOOP)
SET DIR(0)="S^C:CLOSE Open Referral;M:Merge 2 Referrals;D:Display Last 2 Referrals Only;P:New Patient;Q:Quit"
+9 IF STATUS="1^0"!(STATUS="0^0")
SET DIR(0)="S^C:CLOSE Open Referral;P:New Patient;Q:Quit"
+10 DO ^DIR
SET MODE=Y
WRITE !
+11 IF MODE="R"
Begin DoDot:1
+12 SET DIR(0)="NO^"_$ORDER(^TMP("PXRMGEC_CK2",$JOB,0))_":"_CNT_":0"
+13 SET DIR("A")="Enter the number on the Left side of the screen next to the Historical Referral that you want to re-open."
+14 DO ^DIR
+15 SET ROPNNUM=Y
End DoDot:1
+16 IF MODE="M"
Begin DoDot:1
MRG IF STATUS="0^1"
SET DIR(0)="NO^"_CNTA_":"_$SELECT($DATA(LOOP):CNT,1:CNTB)_":0"
+1 IF STATUS="1^1"
SET DIR(0)="NO^"_$ORDER(^TMP("PXRMGEC_CK1",$JOB,0))_":"_CNT_":0"
+2 SET DIR("A")="First Referral Record"
+3 DO ^DIR
IF $DATA(DIRUT)
QUIT
SET FIRST=Y
Begin DoDot:2
+4 IF STATUS="0^1"
SET DIR(0)="NO^"_CNTA_":"_$SELECT($DATA(LOOP):CNT,1:CNTB)_":0"
+5 IF STATUS="1^1"
SET DIR(0)="NO^"_$ORDER(^TMP("PXRMGEC_CK1",$JOB,0))_":"_CNT_":0"
+6 SET DIR("A")="Second Referral Record"
+7 DO ^DIR
IF $DATA(DIRUT)
QUIT
SET SECOND=Y
End DoDot:2
IF $DATA(DIRUT)
QUIT
+8 IF +FIRST>0
IF +SECOND>0
IF FIRST=SECOND
WRITE !,"Try again.."
GOTO MRG
End DoDot:1
IF $DATA(DIRUT)
GOTO ASK
+9 IF MODE="Q"
DO EXIT
+10 IF MODE="R"
DO REOPEN^PXRMGECL(ROPNNUM)
GOTO DISP
+11 IF MODE="M"
DO MERGE(FIRST,SECOND,DFN)
GOTO DISP
+12 IF MODE="V"
SET LOOP=1
GOTO DISP
+13 IF MODE="D"
KILL LOOP
GOTO DISP
+14 IF MODE="P"
GOTO EN
+15 IF MODE="C"
DO FINISHED^PXRMGECU(DFN,1)
GOTO DISP
+16 QUIT
+17 ;
MERGE(FIR,SEC,DFN) ;Merge 2 Referrals
+1 IF FIR=""
QUIT
+2 IF SEC=""
QUIT
+3 IF DFN=""
QUIT
+4 NEW DATE1,DATE2,OLDDT,OLD,SRCHDT
+5 WRITE !,"DO MERGE",!
+6 ;Get Date to use for setting and to be changed.
+7 IF $DATA(^TMP("PXRMGEC_CK1",$JOB,FIR,1))
SET DATE(FIR)=$PIECE($GET(^TMP("PXRMGEC_CK1",$JOB,FIR,1)),"^",2)
+8 IF $DATA(^TMP("PXRMGEC_CK1",$JOB,SEC,1))
SET DATE(SEC)=$PIECE($GET(^TMP("PXRMGEC_CK1",$JOB,SEC,1)),"^",2)
+9 IF $DATA(^TMP("PXRMGEC_CK2",$JOB,FIR))
Begin DoDot:1
+10 NEW SUB3,SUBDA
+11 SET SUB3=$ORDER(^TMP("PXRMGEC_CK2",$JOB,FIR,0))
+12 SET SUBDA=$ORDER(^TMP("PXRMGEC_CK2",$JOB,FIR,SUB3,0))
+13 SET DATE(FIR)=$PIECE($GET(^TMP("PXRMGEC_CK2",$JOB,FIR,SUB3,SUBDA)),"^",2)
End DoDot:1
+14 IF $DATA(^TMP("PXRMGEC_CK2",$JOB,SEC))
Begin DoDot:1
+15 NEW SUB3,SUBDA
+16 SET SUB3=$ORDER(^TMP("PXRMGEC_CK2",$JOB,SEC,0))
+17 SET SUBDA=$ORDER(^TMP("PXRMGEC_CK2",$JOB,SEC,SUB3,0))
+18 SET DATE(SEC)=$PIECE($GET(^TMP("PXRMGEC_CK2",$JOB,SEC,SUB3,SUBDA)),"^",2)
End DoDot:1
+19 SET OLD(DATE(FIR))=FIR
+20 SET OLD(DATE(SEC))=SEC
+21 SET OLDDT=$ORDER(OLD(0))
+22 SET SRCHDT=$ORDER(OLD(OLDDT))
+23 ;
+24 ;List of Health Factors DA's to change
+25 NEW DATE,ARY,GEC,DA,VISIT,ROOT,PKG,SOURCE
+26 NEW HF0,HF12,HF801,HF812,ARY1
+27 SET ARY="^AUPNVHF(""AED"","_SRCHDT_","_DFN_")"
+28 SET GEC=""
FOR
SET GEC=$ORDER(@ARY@(GEC))
IF GEC=""
QUIT
Begin DoDot:1
+29 SET DA=0
FOR
SET DA=$ORDER(@ARY@(GEC,DA))
IF DA=""
QUIT
Begin DoDot:2
+30 SET VISIT=$PIECE($GET(^AUPNVHF(DA,0)),"^",3)
+31 SET ^TMP("PXRMGECMRG",$JOB,VISIT,DA,SRCHDT)=""
End DoDot:2
End DoDot:1
+32 ;
+33 ;Change HF with DATA2PCE
+34 SET I=0
+35 SET ROOT="^TMP(""PXRMGECMRGPCE"",$J)"
+36 SET SOURCE="Geriatric Extended Care Merge"
+37 ;
+38 SET ARY1="^TMP(""PXRMGECMRG"",$J)"
+39 SET VISIT=0
FOR
SET VISIT=$ORDER(@ARY1@(VISIT))
IF VISIT=""
QUIT
Begin DoDot:1
+40 SET DA=0
FOR
SET DA=$ORDER(@ARY1@(VISIT,DA))
IF DA=""
QUIT
Begin DoDot:2
+41 IF $DATA(^AUPNVHF(DA))
Begin DoDot:3
+42 SET HF0=$GET(^AUPNVHF(DA,0))
+43 SET HF12=$GET(^AUPNVHF(DA,12))
+44 SET HF812=$GET(^AUPNVHF(DA,812))
+45 ;
+46 SET PKG=$PIECE(HF812,"^",2)
+47 SET SOURCE=$PIECE(HF812,"^",3)
+48 SET USER=DUZ
+49 SET @ROOT@("HEALTH FACTOR",DA,"HEALTH FACTOR")=$PIECE(HF0,"^",1)
+50 SET @ROOT@("HEALTH FACTOR",DA,"LEVEL/SEVERITY")=$PIECE(HF0,"^",4)
+51 SET @ROOT@("HEALTH FACTOR",DA,"ENC PROVIDER")=$PIECE(HF12,"^",4)
+52 SET @ROOT@("HEALTH FACTOR",DA,"EVENT D/T")=OLDDT
End DoDot:3
End DoDot:2
+53 IF $DATA(^TMP("PXRMGECMRGPCE",$JOB))
Begin DoDot:2
+54 NEW NOEVT
+55 SET NOEVT="PXKNOEVT"
+56 SET @NOEVT=1
+57 SET OK=$$DATA2PCE^PXAPI(ROOT,PKG,SOURCE,.VISIT,USER,"","","")
End DoDot:2
End DoDot:1
+58 ;
+59 ;Change 801.55
+60 NEW GEC,DA,GECX,GECM
+61 ;
+62 SET GEC=""
FOR
SET GEC=$ORDER(^PXRMD(801.55,"AC",DFN,SRCHDT,GEC))
IF GEC=""
QUIT
Begin DoDot:1
+63 SET DA=0
FOR
SET DA=$ORDER(^PXRMD(801.55,"AC",DFN,SRCHDT,GEC,DA))
IF DA=""
QUIT
Begin DoDot:2
+64 SET GECX(1,801.55,DA_",",.02)=OLDDT
+65 DO FILE^DIE("","GECX(1)")
KILL GECX
+66 ;
+67 IF FIR=$ORDER(^TMP("PXRMGEC_CK1",$JOB,0))
Begin DoDot:3
+68 ;I FIR=1!(SEC=1) D
+69 IF '$DATA(^PXRMD(801.5,"AC",DFN,SRCHDT,GEC))
Begin DoDot:4
+70 SET GECM(1,801.5,"+1,",.01)=$PIECE($GET(^PXRMD(801.55,DA,0)),"^",1)
+71 SET GECM(1,801.5,"+1,",.02)=$PIECE($GET(^PXRMD(801.55,DA,0)),"^",2)
+72 SET GECM(1,801.5,"+1,",.03)=$PIECE($GET(^PXRMD(801.55,DA,0)),"^",3)
+73 SET GECM(1,801.5,"+1,",.04)=$PIECE($GET(^PXRMD(801.55,DA,0)),"^",4)
+74 SET GECM(1,801.5,"+1,",.05)=$PIECE($GET(^PXRMD(801.55,DA,0)),"^",5)
+75 SET GECM(1,801.5,"+1,",.06)=$PIECE($GET(^PXRMD(801.55,DA,0)),"^",6)
+76 DO UPDATE^DIE("","GECM(1)")
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+77 ;
+78 ;
+79 ;Change 801.5
+80 NEW GEC,DA,GECX
+81 ;
+82 SET GEC=""
FOR
SET GEC=$ORDER(^PXRMD(801.5,"AC",DFN,SRCHDT,GEC))
IF GEC=""
QUIT
Begin DoDot:1
+83 SET DA=0
FOR
SET DA=$ORDER(^PXRMD(801.5,"AC",DFN,SRCHDT,GEC,DA))
IF DA=""
QUIT
Begin DoDot:2
+84 SET GECX(1,801.5,DA_",",.02)=OLDDT
+85 DO FILE^DIE("","GECX(1)")
KILL GECX
End DoDot:2
End DoDot:1
+86 ;EXIT
+87 KILL ^TMP("PXRMGECMRG",$JOB)
+88 KILL ^TMP("PXRMGECMRGPCE",$JOB)
+89 QUIT
+90 ;
+91 ;
PAT ;LOOK UP ALL PATIENTS
+1 WRITE @IOF,!
+2 SET DIR(0)="801.55,.01"
+3 DO ^DIR
+4 SET DFN=+Y
+5 KILL Y,Y(0),Y(0,0)
+6 QUIT
+7 ;
CK1(DFN) ;Check for current open referral
+1 IF DFN'>0
QUIT
+2 NEW STATUS,I,Z
+3 KILL ^TMP("PXRMGEC_CK1",$JOB)
+4 SET STATUS=0
SET I=1
SET J=0
+5 ;S Z=$$CK2(DFN) S I=$O(^TMP("PXRMGEC_CK2",$J,0))-1
+6 IF $DATA(^PXRMD(801.5,"B",DFN))
Begin DoDot:1
+7 SET DA=0
FOR
SET DA=$ORDER(^PXRMD(801.5,"B",DFN,DA))
IF DA=""
QUIT
SET J=J+1
Begin DoDot:2
+8 SET ^TMP("PXRMGEC_CK1",$JOB,I,J)=$GET(^PXRMD(801.5,DA,0))
End DoDot:2
+9 SET STATUS=1
End DoDot:1
+10 QUIT STATUS
+11 ;
CK2(DFN) ;Check for entries in History file 801.55
+1 IF DFN'>0
QUIT
+2 NEW STATUS,I,CURRENT,DATE,DIA,DA,J
+3 KILL ^TMP("PXRMGEC_CK2",$JOB)
+4 SET STATUS=0
SET I=1000
SET J=0
+5 IF $DATA(^TMP("PXRMGEC_CK1",$JOB))
SET CURRENT=$PIECE($GET(^TMP("PXRMGEC_CK1",$JOB,$ORDER(^TMP("PXRMGEC_CK1",$JOB,0)),1)),"^",2)
+6 IF $DATA(^PXRMD(801.55,"B",DFN))
Begin DoDot:1
+7 SET DATE=""
FOR
SET DATE=$ORDER(^PXRMD(801.55,"AC",DFN,DATE))
IF DATE=""
QUIT
Begin DoDot:2
+8 IF $GET(CURRENT)=DATE
QUIT
+9 SET I=I-1
+10 SET DIA=""
FOR
SET DIA=$ORDER(^PXRMD(801.55,"AC",DFN,DATE,DIA))
IF DIA=""
QUIT
Begin DoDot:3
+11 SET J=J+1
+12 SET DA=0
FOR
SET DA=$ORDER(^PXRMD(801.55,"AC",DFN,DATE,DIA,DA))
IF DA=""
QUIT
Begin DoDot:4
+13 SET ^TMP("PXRMGEC_CK2",$JOB,I,J,DA)=$GET(^PXRMD(801.55,DA,0))
+14 SET STATUS=1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+15 ;RENUMBER ARRAY
+16 IF $DATA(^TMP("PXRMGEC_CK2",$JOB))
Begin DoDot:1
+17 NEW OLD,NEW,J,DA,DATA
+18 SET NEW=1
+19 SET OLD=0
FOR
SET OLD=$ORDER(^TMP("PXRMGEC_CK2",$JOB,OLD))
IF OLD=""
QUIT
Begin DoDot:2
+20 SET NEW=NEW+1
+21 SET J=0
FOR
SET J=$ORDER(^TMP("PXRMGEC_CK2",$JOB,OLD,J))
IF J=""
QUIT
Begin DoDot:3
+22 SET DA=0
FOR
SET DA=$ORDER(^TMP("PXRMGEC_CK2",$JOB,OLD,J,DA))
IF DA=""
QUIT
Begin DoDot:4
+23 SET DATA=$GET(^TMP("PXRMGEC_CK2",$JOB,OLD,J,DA))
+24 SET ^TMP("PXRMGEC_CK2",$JOB,NEW,J,DA)=DATA
+25 KILL ^TMP("PXRMGEC_CK2",$JOB,OLD,J,DA)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+26 QUIT STATUS
+27 ;
DIALOG(DIA) ;Returns expanded name of dialog
+1 NEW NAME
+2 SET NAME=""
+3 IF DIA="GEC1"
SET NAME="Social Services"
+4 IF DIA="GEC2"
SET NAME="Nursing Assessment"
+5 IF DIA="GEC3"
SET NAME="Care Recommendation"
+6 IF DIA="GECF"
SET NAME="Care Coordination"
+7 QUIT NAME
+8 ;
EXIT ;CLEAN UP
+1 KILL CK2,LOOP,X,CNTA,CNTB,ROPNNUM
+2 KILL ^TMP("PXRMGEC_CK1",$JOB),^TMP("PXRMGEC_CK2",$JOB)
+3 QUIT
+4 ;
