CRHD2 ; CAIRO/CLC - GET DATA ITEMS FOR CHANGEOVER LIST ;08-Apr-2008 08:03;CLC
;;1.0;CRHD;****;Jan 28, 2008;Build 19
;=================================================================
CODESTS(CRHDRTN,CRHDSTR) ;CODE STATUS -using orders, try to find and orderable item for DNR, if not found look for a text order
; by the name of DNRTITLE, title also set up as a p
;DFN - patient internal entry number to Patient file
;DNRTITLE - DNR order title if not defined by a parameter
;DIVISION - the division user logged into
;LEN - length of text to return for each line, default:18
;DTFLG - return the start date and stop date for order default:yes
;
N CRHDDFN,CRHDDNRT,CRHDDIV,CRHDLEN,CRHDX,CRHDY,CRHDCT,CRHDMDNR,CRHDQQFG
N CRHDDTFG,CRHDOCT,CRHDSR,CRHDO,CRHDT,CRHDQ,CRHDQ1,CRHDQX,CRHDTMP,CRHDQY,CRHDFLG
K CRHDRTN
S CRHDDFN=+CRHDSTR
S CRHDDNRT=$P(CRHDSTR,U,2)
S CRHDDIV=$P(CRHDSTR,U,3)
S CRHDLEN=$P(CRHDSTR,U,4)
I 'CRHDLEN S CRHDLEN=18
S CRHDDTFG=$P(CRHDSTR,U,5)
I CRHDDTFG="" S CRHDDTFG=1
S CRHDMDNR=+$P(CRHDSTR,U,6)
D ENT^CRHDDR(.CRHDO,CRHDDFN,.CRHDDNRT,.CRHDDIV,CRHDMDNR)
D ENT^CRHDDNR(.CRHDT,CRHDDFN,.CRHDDNRT,.CRHDDIV,CRHDMDNR)
S CRHDQ=0 F S CRHDQ=$O(CRHDO(CRHDQ)) Q:'CRHDQ I $P(CRHDO(CRHDQ),"~",1)&(CRHDO(CRHDQ)["~") S CRHDTMP($P(CRHDO(CRHDQ),"~",1),$P(CRHDO(CRHDQ),"~",2))="CRHDO^"_CRHDQ
S CRHDQ=0 F S CRHDQ=$O(CRHDT(CRHDQ)) Q:'CRHDQ I $P(CRHDT(CRHDQ),"~",1)&(CRHDT(CRHDQ)["~") S CRHDTMP($P(CRHDT(CRHDQ),"~",1),$P(CRHDT(CRHDQ),"~",2))="CRHDT^"_CRHDQ
S (CRHDCT,CRHDQQFG)=0
S CRHDQ=0 F CRHDI=1:1 S CRHDQ=$O(CRHDTMP(CRHDQ)) Q:'CRHDQ!(CRHDQQFG) S CRHDQ1=0 F S CRHDQ1=$O(CRHDTMP(CRHDQ,CRHDQ1)) Q:'CRHDQ1 D
.S CRHDQFLG=0
.I 'CRHDMDNR S CRHDQQFG=1
.S CRHDQX=$P(CRHDTMP(CRHDQ,CRHDQ1),"^",1),CRHDQY=$P(CRHDTMP(CRHDQ,CRHDQ1),"^",2)
.S CRHDQ2=CRHDQY-1,CRHDQFLG=0 F S CRHDQ2=$O(@CRHDQX@(CRHDQ2)) Q:'CRHDQ2!(CRHDQFLG) D
..I (CRHDQ2'=CRHDQY)&(@CRHDQX@(CRHDQ2)["~") S CRHDQFLG=1 S:('CRHDMDNR)&(CRHDI>1) CRHDQQFG=1 Q
..I (CRHDQ2'=CRHDQY)&(@CRHDQX@(CRHDQ2)["~") S CRHDQFLG=1 Q
..S CRHDCT=CRHDCT+1
..I @CRHDQX@(CRHDQ2)["~" S CRHDRTN(CRHDCT)=$P(@CRHDQX@(CRHDQ2),"~",3)
..E S CRHDRTN(CRHDCT)=@CRHDQX@(CRHDQ2)
I $D(CRHDRTN) D
.S CRHDX=0,CRHDCT=1
.F S CRHDX=$O(CRHDRTN(CRHDX)) Q:'CRHDX D
..I $L(CRHDRTN(CRHDX))>CRHDLEN D
...F Q:$L(CRHDRTN(CRHDX))=0 S CRHDCT=CRHDCT+1,CRHDY(CRHDCT)=$E(CRHDRTN(CRHDX),1,CRHDLEN),CRHDRTN(CRHDX)=$E(CRHDRTN(CRHDX),CRHDLEN+1,9999)
..E D
...I CRHDRTN(CRHDX)["Stop Date" S CRHDY(CRHDCT)=CRHDY(CRHDCT)_" "_CRHDRTN(CRHDX) D
....I $L(CRHDY(CRHDCT))>CRHDLEN S CRHDOCT=CRHDCT,CRHDSR=CRHDY(CRHDCT) F Q:$L(CRHDSR)=0 S CRHDY(CRHDCT)=$E(CRHDSR,1,CRHDLEN),CRHDSR=$E(CRHDSR,CRHDLEN+1,9999),CRHDOCT=CRHDOCT+1
...E S CRHDCT=CRHDCT+1,CRHDY(CRHDCT)=CRHDRTN(CRHDX)
K CRHDRTN
M CRHDRTN=CRHDY
I CRHDCT>1 S CRHDRTN(1)=CRHDCT-1
I $G(CRHDRTN(2))="" S CRHDRTN(1)=1,CRHDRTN(2)="Code Status Not Found"
Q
NODETAM(CRHDY,CRHDDFN,CRHDCAT) ;GET ACTIVE MEDS WITHOUT THE DETAILS, FOR ACTIVE MEDS WITH DETAILS USE CRHDAM
;CRHDCAT :I - inpatient
; O - outpatient
N CRHDP1,CRHDP2,CRHDPP1,CRHDPP2,CRHDCT,CRHDN2,CRHDN3,CRHDRTN,CRHDSORT
N CRHDN
S CRHDCT=0
D COVER^ORWPS(.CRHDRTN,CRHDDFN)
I '$D(CRHDRTN) Q
S CRHDN=0
F S CRHDN=$O(CRHDRTN(CRHDN)) Q:'CRHDN D
.S CRHDP1=$P(CRHDRTN(CRHDN),"^",1)
.S CRHDPP1=$P(CRHDP1,";",1)
.S CRHDPP2=$P(CRHDP1,";",2)
.I CRHDCAT="O"&(CRHDPP2="O") D SORT
.I CRHDCAT="I"&(CRHDPP2="I") D SORT
D OUTPUT Q
Q
SORT ;
I $P(CRHDRTN(CRHDN),"^",4)'["ACTIVE" Q
S CRHDSORT($E(CRHDPP1,$L(CRHDPP1)),$P(CRHDRTN(CRHDN),"^",2),CRHDPP1)=""
Q
OUTPUT ;
S CRHDN=""
F S CRHDN=$O(CRHDSORT(CRHDN)) Q:CRHDN="" D
.S CRHDN2="" F S CRHDN2=$O(CRHDSORT(CRHDN,CRHDN2)) Q:CRHDN2="" D
..S CRHDN3="" F S CRHDN3=$O(CRHDSORT(CRHDN,CRHDN2,CRHDN3)) Q:CRHDN3="" D
...S CRHDCT=CRHDCT+1
...I CRHDCAT="O"&(CRHDN="N") S CRHDY(CRHDN,CRHDCT)="NON-VA "_CRHDN2 Q
...S CRHDY(CRHDN,CRHDCT)=CRHDN2
S CRHDY(0)=CRHDCT_"^"_CRHDCAT_$S(CRHDCAT="O":"UT",1:"N")_"PATIENT"
Q
TEMPDATA(CRHDRTN,CRHDFLDN,CRHDUSER,CRHDDFN,CRHDTXT) ;TEMPORARY DATA, DATA ONLY USE FOR A SHORT TIME FRAME
;CRHDFLD - TEMP FIELD NAME
;CRHDUSER - AUTHOR OF THE NOTE
;if fld already has the author then this is 'WHO LAST EDITED'
;CRHDDFN - Patient
;TEXT - Text to be stored
N CRHDFDA,CRHDOUT,CRHDERR,CRHDFN,CRHDUPZ,CRHDUPZZ,CRHDPZZZ
K CRHDRTN,CRHDUPY
S CRHDFLDN=$$UP^XLFSTR(CRHDFLDN)
S CRHDUPY=$$CHK(CRHDFLDN,CRHDUSER,CRHDDFN)
S CRHDUPZ=$P(CRHDUPY,"^",2)
I CRHDUPZ="+1," S CRHDUPZZ="?+1,",CRHDPZZZ="?+2,"
E S CRHDUPZZ="?+2,"
I CRHDUPZ="+1," S CRHDUPZ=CRHDUPZZ,CRHDUPZZ=CRHDPZZZ D NEW
E D UPDATE(CRHDFLDN,CRHDUSER,CRHDDFN,.CRHDTXT)
I $D(CRHDERR) D Q
.S ^CRHDER($$NOW^XLFDT,"ERROR-UPDATING DATA")=CRHDFLDN_U_CRHDUSER_U_CRHDDFN
.M ^CRHDER($$NOW^XLFDT,"ERROR-UPDATING DATA")=CRHDTXT Q
.K CRHDERR,CRHDOUT,CRHDFDA
.S CRHDRTN(1)=0_"^ERROR SAVING DATA..."
E S CRHDRTN(1)=1_"^SAVE SUCCESSFUL..."
Q
NEW S CRHDFDA(183.21,CRHDUPZZ_CRHDUPZ,1)=CRHDUSER
S CRHDFDA(183.21,CRHDUPZZ_CRHDUPZ,2)=$$NOW^XLFDT
S CRHDFDA(183.21,CRHDUPZZ_CRHDUPZ,5)=0
D UPDATE(CRHDFLDN,CRHDUSER,CRHDDFN,.CRHDTXT)
I $D(CRHDERR) D
.S ^CRHDER($$NOW^XLFDT,"ERROR-ADDING DATA")=CRHDFLDN_U_CRHDUSER_U_CRHDDFN
.M ^CRHDER($$NOW^XLFDT,"ERROR-ADDING DATA")=CRHDTXT Q
.K CRHDERR,CRHDOUT,CRHDFDA
Q
UPDATE(CRHDFLD,CRHDUSER,CRHDDFN,CRHDTXT) ;
;SEE NEWDATA
S CRHDFDA(183.2,"?+1,",.01)=CRHDFLD
S CRHDFDA(183.21,CRHDUPZZ_CRHDUPZ,.01)=CRHDDFN
S CRHDFDA(183.21,CRHDUPZZ_CRHDUPZ,3)=CRHDUSER
S CRHDFDA(183.21,CRHDUPZZ_CRHDUPZ,4)=$$NOW^XLFDT
D UPDATE^DIE("","CRHDFDA","CRHDOUT","CRHDERR")
S CRHDIEN=$G(CRHDOUT(1)),CRHDMIEN=$G(CRHDOUT(2))
L +^CRHD(183.2,CRHDIEN,1,CRHDMIEN):1 I '$T Q
I '$D(CRHDERR) D STORETXT(CRHDIEN,CRHDMIEN,.CRHDTXT)
L -^CRHD(183.2,CRHDIEN,1,CRHDMIEN)
Q
STORETXT(CRHDIEN,CRHDMIEN,CRHDTARY) ;store text to file
N CRHDTRG,CRHDFG,CRHDX,CRHDCT,CRHDLINE
Q:'CRHDIEN&('CRHDMIEN)
S CRHDTRG="CRHDTARY"
Q:'$D(@CRHDTRG)
;D SAVEOLD(CRHDIEN,CRHDMIEN)
K ^CRHD(183.2,CRHDIEN,1,CRHDMIEN,"TEXT")
S ^CRHD(183.2,CRHDIEN,1,CRHDMIEN,"TEXT",0)="^^^^"_$$DT^XLFDT
S CRHDX=0 F CRHDLINE=0:1 S CRHDX=$O(@CRHDTRG@(CRHDX)) Q:'CRHDX
S (CRHDFG,CRHDX,CRHDCT)=0
F S CRHDX=$O(@CRHDTRG@(CRHDX)) Q:'CRHDX!(CRHDFG) D
.I $D(@CRHDTRG@(CRHDX,0)) D Q
..M ^CRHD(183.2,CRHDIEN,1,CRHDMIEN,"TEXT")=@CRHDTRG
..S $P(^CRHD(183.2,CRHDIEN,1,CRHDMIEN,"TEXT",0),"^",3,4)=CRHDLINE_"^"_CRHDLINE
..S CRHDFG=1
.I $G(@CRHDTRG@(CRHDX))'="" D
..S CRHDCT=CRHDCT+1
..S ^CRHD(183.2,CRHDIEN,1,CRHDMIEN,"TEXT",CRHDCT,0)=@CRHDTRG@(CRHDX)
..S $P(^CRHD(183.2,CRHDIEN,1,CRHDMIEN,"TEXT",0),"^",3,4)=CRHDCT_"^"_CRHDCT
Q
SAVEOLD(CRHDIEN,CRHDMIEN) ;
I $D(^CRHD(183.2,CRHDIEN,1,CRHDMIEN,"TEXT")) D
.K ^CRHD(183.2,CRHDIEN,1,CRHDMIEN,"ZOLD_TEXT")
.M ^CRHD(183.2,CRHDIEN,1,CRHDMIEN,"ZOLD_TEXT")=^CRHD(183.2,CRHDIEN,1,CRHDMIEN,"TEXT")
Q
CHK(CRHDFLDN,CRHDUSER,CRHDDFN) ;
N CRHDFLG,CRHDX,CRHDP ;FLG = 1 if record already exist
S CRHDFLG=0
S CRHDFN=183.2
S CRHDFLD=$O(^CRHD(CRHDFN,"B",CRHDFLDN,0))
I $D(^CRHD(CRHDFN,"C",+CRHDDFN,+CRHDFLD)) D
.S:CRHDFLD CRHDFLG=1
I CRHDFLG S CRHDFLG=CRHDFLG_"^"_CRHDFLD_","
E S CRHDFLG=CRHDFLG_"^"_"+1,"
Q CRHDFLG
XREF(CRHDIEN,CRHDMIEN) ;SET THE XREF FOR SPECIALTY AND TEAM
N CRHDTM,CRHDTSP,CRHDAUTH,CRHDPAT
S CRHDAUTH=$P($G(^CRHD(183.2,CRHDIEN,1,CRHDMIEN,0)),"^",2)
Q:'CRHDAUTH
S CRHDPAT=$P($G(^CRHD(183.2,CRHDIEN,1,CRHDMIEN,0)),"^",1)
;do not set up reference if a private note
Q:+$P($G(^CRHD(183.2,CRHDIEN,1,CRHDMIEN,0)),"^",6)
S CRHDTM=$$GET^XPAR("USR.`"_CRHDAUTH,"ORLP DEFAULT TEAM",1,"I")
S CRHDTSP=$$GET^XPAR("USR.`"_CRHDAUTH,"ORLP DEFAULT SPECIALTY",1,"I")
S:+CRHDTM ^CRHD(183.2,"AC","TM",CRHDTM,CRHDPAT,CRHDIEN,CRHDMIEN)=""
S:+CRHDTSP ^CRHD(183.2,"AC","TSP",CRHDTSP,CRHDPAT,CRHDIEN,CRHDMIEN)=""
Q
KILXREF(CRHDIEN,CRHDMIEN) ;KILL XREF FOR SPECIALTY AND TEAM
N CRHDTM,CRHDTSP,CRHDAUTH,CRHDPAT
S CRHDAUTH=$P($G(^CRHD(183.2,CRHDIEN,1,CRHDMIEN,0)),"^",2)
Q:'CRHDAUTH
S CRHDPAT=$P($G(^CRHD(183.2,CRHDIEN,1,CRHDMIEN,0)),"^",1)
S CRHDTM=$$GET^XPAR("USR.`"_CRHDAUTH,"ORLP DEFAULT TEAM",1,"I")
S CRHDTSP=$$GET^XPAR("USR.`"_CRHDAUTH,"ORLP DEFAULT SPECIALTY",1,"I")
K:+CRHDTM ^CRHD(183.2,"AC","TM",CRHDTM,CRHDPAT,CRHDIEN,CRHDMIEN)
K:+CRHDTSP ^CRHD(183.2,"AC","TSP",CRHDTSP,CRHDPAT,CRHDIEN,CRHDMIEN)
Q
ONOFFPRV(CRHDPRIV,CRHDIEN,CRHDMIEN) ;ON/OFF PRIVATE NOTE
I 'CRHDPRIV D XREF(CRHDIEN,CRHDMIEN)
I +CRHDPRIV D KILXREF(CRHDIEN,CRHDMIEN)
Q
LOCK(CRHDRTN,CRHDDFN,CRHDFLDM) ;
N CRHDIEN,CRHDMIEN
S CRHDRTN=0
S CRHDFLDM=$$UP^XLFSTR(CRHDFLDM)
S CRHDIEN=$O(^CRHD(183.2,"B",CRHDFLDM,0))
S CRHDMIEN=$O(^CRHD(183.2,"C",+CRHDDFN,+CRHDIEN,0))
Q:'CRHDMIEN
L +^CRHD(183.2,CRHDIEN,1,CRHDMIEN):10 I '$T S CRHDRTN=1 ;_"^0^Another user is editing this task"
L -^CRHD(183.2,CRHDIEN,1,CRHDMIEN)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HCRHD2 8857 printed Oct 16, 2024@18:38:23 Page 2
CRHD2 ; CAIRO/CLC - GET DATA ITEMS FOR CHANGEOVER LIST ;08-Apr-2008 08:03;CLC
+1 ;;1.0;CRHD;****;Jan 28, 2008;Build 19
+2 ;=================================================================
CODESTS(CRHDRTN,CRHDSTR) ;CODE STATUS -using orders, try to find and orderable item for DNR, if not found look for a text order
+1 ; by the name of DNRTITLE, title also set up as a p
+2 ;DFN - patient internal entry number to Patient file
+3 ;DNRTITLE - DNR order title if not defined by a parameter
+4 ;DIVISION - the division user logged into
+5 ;LEN - length of text to return for each line, default:18
+6 ;DTFLG - return the start date and stop date for order default:yes
+7 ;
+8 NEW CRHDDFN,CRHDDNRT,CRHDDIV,CRHDLEN,CRHDX,CRHDY,CRHDCT,CRHDMDNR,CRHDQQFG
+9 NEW CRHDDTFG,CRHDOCT,CRHDSR,CRHDO,CRHDT,CRHDQ,CRHDQ1,CRHDQX,CRHDTMP,CRHDQY,CRHDFLG
+10 KILL CRHDRTN
+11 SET CRHDDFN=+CRHDSTR
+12 SET CRHDDNRT=$PIECE(CRHDSTR,U,2)
+13 SET CRHDDIV=$PIECE(CRHDSTR,U,3)
+14 SET CRHDLEN=$PIECE(CRHDSTR,U,4)
+15 IF 'CRHDLEN
SET CRHDLEN=18
+16 SET CRHDDTFG=$PIECE(CRHDSTR,U,5)
+17 IF CRHDDTFG=""
SET CRHDDTFG=1
+18 SET CRHDMDNR=+$PIECE(CRHDSTR,U,6)
+19 DO ENT^CRHDDR(.CRHDO,CRHDDFN,.CRHDDNRT,.CRHDDIV,CRHDMDNR)
+20 DO ENT^CRHDDNR(.CRHDT,CRHDDFN,.CRHDDNRT,.CRHDDIV,CRHDMDNR)
+21 SET CRHDQ=0
FOR
SET CRHDQ=$ORDER(CRHDO(CRHDQ))
if 'CRHDQ
QUIT
IF $PIECE(CRHDO(CRHDQ),"~",1)&(CRHDO(CRHDQ)["~")
SET CRHDTMP($PIECE(CRHDO(CRHDQ),"~",1),$PIECE(CRHDO(CRHDQ),"~",2))="CRHDO^"_CRHDQ
+22 SET CRHDQ=0
FOR
SET CRHDQ=$ORDER(CRHDT(CRHDQ))
if 'CRHDQ
QUIT
IF $PIECE(CRHDT(CRHDQ),"~",1)&(CRHDT(CRHDQ)["~")
SET CRHDTMP($PIECE(CRHDT(CRHDQ),"~",1),$PIECE(CRHDT(CRHDQ),"~",2))="CRHDT^"_CRHDQ
+23 SET (CRHDCT,CRHDQQFG)=0
+24 SET CRHDQ=0
FOR CRHDI=1:1
SET CRHDQ=$ORDER(CRHDTMP(CRHDQ))
if 'CRHDQ!(CRHDQQFG)
QUIT
SET CRHDQ1=0
FOR
SET CRHDQ1=$ORDER(CRHDTMP(CRHDQ,CRHDQ1))
if 'CRHDQ1
QUIT
Begin DoDot:1
+25 SET CRHDQFLG=0
+26 IF 'CRHDMDNR
SET CRHDQQFG=1
+27 SET CRHDQX=$PIECE(CRHDTMP(CRHDQ,CRHDQ1),"^",1)
SET CRHDQY=$PIECE(CRHDTMP(CRHDQ,CRHDQ1),"^",2)
+28 SET CRHDQ2=CRHDQY-1
SET CRHDQFLG=0
FOR
SET CRHDQ2=$ORDER(@CRHDQX@(CRHDQ2))
if 'CRHDQ2!(CRHDQFLG)
QUIT
Begin DoDot:2
+29 IF (CRHDQ2'=CRHDQY)&(@CRHDQX@(CRHDQ2)["~")
SET CRHDQFLG=1
if ('CRHDMDNR)&(CRHDI>1)
SET CRHDQQFG=1
QUIT
+30 IF (CRHDQ2'=CRHDQY)&(@CRHDQX@(CRHDQ2)["~")
SET CRHDQFLG=1
QUIT
+31 SET CRHDCT=CRHDCT+1
+32 IF @CRHDQX@(CRHDQ2)["~"
SET CRHDRTN(CRHDCT)=$PIECE(@CRHDQX@(CRHDQ2),"~",3)
+33 IF '$TEST
SET CRHDRTN(CRHDCT)=@CRHDQX@(CRHDQ2)
End DoDot:2
End DoDot:1
+34 IF $DATA(CRHDRTN)
Begin DoDot:1
+35 SET CRHDX=0
SET CRHDCT=1
+36 FOR
SET CRHDX=$ORDER(CRHDRTN(CRHDX))
if 'CRHDX
QUIT
Begin DoDot:2
+37 IF $LENGTH(CRHDRTN(CRHDX))>CRHDLEN
Begin DoDot:3
+38 FOR
if $LENGTH(CRHDRTN(CRHDX))=0
QUIT
SET CRHDCT=CRHDCT+1
SET CRHDY(CRHDCT)=$EXTRACT(CRHDRTN(CRHDX),1,CRHDLEN)
SET CRHDRTN(CRHDX)=$EXTRACT(CRHDRTN(CRHDX),CRHDLEN+1,9999)
End DoDot:3
+39 IF '$TEST
Begin DoDot:3
+40 IF CRHDRTN(CRHDX)["Stop Date"
SET CRHDY(CRHDCT)=CRHDY(CRHDCT)_" "_CRHDRTN(CRHDX)
Begin DoDot:4
+41 IF $LENGTH(CRHDY(CRHDCT))>CRHDLEN
SET CRHDOCT=CRHDCT
SET CRHDSR=CRHDY(CRHDCT)
FOR
if $LENGTH(CRHDSR)=0
QUIT
SET CRHDY(CRHDCT)=$EXTRACT(CRHDSR,1,CRHDLEN)
SET CRHDSR=$EXTRACT(CRHDSR,CRHDLEN+1,9999)
SET CRHDOCT=CRHDOCT+1
End DoDot:4
+42 IF '$TEST
SET CRHDCT=CRHDCT+1
SET CRHDY(CRHDCT)=CRHDRTN(CRHDX)
End DoDot:3
End DoDot:2
End DoDot:1
+43 KILL CRHDRTN
+44 MERGE CRHDRTN=CRHDY
+45 IF CRHDCT>1
SET CRHDRTN(1)=CRHDCT-1
+46 IF $GET(CRHDRTN(2))=""
SET CRHDRTN(1)=1
SET CRHDRTN(2)="Code Status Not Found"
+47 QUIT
NODETAM(CRHDY,CRHDDFN,CRHDCAT) ;GET ACTIVE MEDS WITHOUT THE DETAILS, FOR ACTIVE MEDS WITH DETAILS USE CRHDAM
+1 ;CRHDCAT :I - inpatient
+2 ; O - outpatient
+3 NEW CRHDP1,CRHDP2,CRHDPP1,CRHDPP2,CRHDCT,CRHDN2,CRHDN3,CRHDRTN,CRHDSORT
+4 NEW CRHDN
+5 SET CRHDCT=0
+6 DO COVER^ORWPS(.CRHDRTN,CRHDDFN)
+7 IF '$DATA(CRHDRTN)
QUIT
+8 SET CRHDN=0
+9 FOR
SET CRHDN=$ORDER(CRHDRTN(CRHDN))
if 'CRHDN
QUIT
Begin DoDot:1
+10 SET CRHDP1=$PIECE(CRHDRTN(CRHDN),"^",1)
+11 SET CRHDPP1=$PIECE(CRHDP1,";",1)
+12 SET CRHDPP2=$PIECE(CRHDP1,";",2)
+13 IF CRHDCAT="O"&(CRHDPP2="O")
DO SORT
+14 IF CRHDCAT="I"&(CRHDPP2="I")
DO SORT
End DoDot:1
+15 DO OUTPUT
QUIT
+16 QUIT
SORT ;
+1 IF $PIECE(CRHDRTN(CRHDN),"^",4)'["ACTIVE"
QUIT
+2 SET CRHDSORT($EXTRACT(CRHDPP1,$LENGTH(CRHDPP1)),$PIECE(CRHDRTN(CRHDN),"^",2),CRHDPP1)=""
+3 QUIT
OUTPUT ;
+1 SET CRHDN=""
+2 FOR
SET CRHDN=$ORDER(CRHDSORT(CRHDN))
if CRHDN=""
QUIT
Begin DoDot:1
+3 SET CRHDN2=""
FOR
SET CRHDN2=$ORDER(CRHDSORT(CRHDN,CRHDN2))
if CRHDN2=""
QUIT
Begin DoDot:2
+4 SET CRHDN3=""
FOR
SET CRHDN3=$ORDER(CRHDSORT(CRHDN,CRHDN2,CRHDN3))
if CRHDN3=""
QUIT
Begin DoDot:3
+5 SET CRHDCT=CRHDCT+1
+6 IF CRHDCAT="O"&(CRHDN="N")
SET CRHDY(CRHDN,CRHDCT)="NON-VA "_CRHDN2
QUIT
+7 SET CRHDY(CRHDN,CRHDCT)=CRHDN2
End DoDot:3
End DoDot:2
End DoDot:1
+8 SET CRHDY(0)=CRHDCT_"^"_CRHDCAT_$SELECT(CRHDCAT="O":"UT",1:"N")_"PATIENT"
+9 QUIT
TEMPDATA(CRHDRTN,CRHDFLDN,CRHDUSER,CRHDDFN,CRHDTXT) ;TEMPORARY DATA, DATA ONLY USE FOR A SHORT TIME FRAME
+1 ;CRHDFLD - TEMP FIELD NAME
+2 ;CRHDUSER - AUTHOR OF THE NOTE
+3 ;if fld already has the author then this is 'WHO LAST EDITED'
+4 ;CRHDDFN - Patient
+5 ;TEXT - Text to be stored
+6 NEW CRHDFDA,CRHDOUT,CRHDERR,CRHDFN,CRHDUPZ,CRHDUPZZ,CRHDPZZZ
+7 KILL CRHDRTN,CRHDUPY
+8 SET CRHDFLDN=$$UP^XLFSTR(CRHDFLDN)
+9 SET CRHDUPY=$$CHK(CRHDFLDN,CRHDUSER,CRHDDFN)
+10 SET CRHDUPZ=$PIECE(CRHDUPY,"^",2)
+11 IF CRHDUPZ="+1,"
SET CRHDUPZZ="?+1,"
SET CRHDPZZZ="?+2,"
+12 IF '$TEST
SET CRHDUPZZ="?+2,"
+13 IF CRHDUPZ="+1,"
SET CRHDUPZ=CRHDUPZZ
SET CRHDUPZZ=CRHDPZZZ
DO NEW
+14 IF '$TEST
DO UPDATE(CRHDFLDN,CRHDUSER,CRHDDFN,.CRHDTXT)
+15 IF $DATA(CRHDERR)
Begin DoDot:1
+16 SET ^CRHDER($$NOW^XLFDT,"ERROR-UPDATING DATA")=CRHDFLDN_U_CRHDUSER_U_CRHDDFN
+17 MERGE ^CRHDER($$NOW^XLFDT,"ERROR-UPDATING DATA")=CRHDTXT
QUIT
+18 KILL CRHDERR,CRHDOUT,CRHDFDA
+19 SET CRHDRTN(1)=0_"^ERROR SAVING DATA..."
End DoDot:1
QUIT
+20 IF '$TEST
SET CRHDRTN(1)=1_"^SAVE SUCCESSFUL..."
+21 QUIT
NEW SET CRHDFDA(183.21,CRHDUPZZ_CRHDUPZ,1)=CRHDUSER
+1 SET CRHDFDA(183.21,CRHDUPZZ_CRHDUPZ,2)=$$NOW^XLFDT
+2 SET CRHDFDA(183.21,CRHDUPZZ_CRHDUPZ,5)=0
+3 DO UPDATE(CRHDFLDN,CRHDUSER,CRHDDFN,.CRHDTXT)
+4 IF $DATA(CRHDERR)
Begin DoDot:1
+5 SET ^CRHDER($$NOW^XLFDT,"ERROR-ADDING DATA")=CRHDFLDN_U_CRHDUSER_U_CRHDDFN
+6 MERGE ^CRHDER($$NOW^XLFDT,"ERROR-ADDING DATA")=CRHDTXT
QUIT
+7 KILL CRHDERR,CRHDOUT,CRHDFDA
End DoDot:1
+8 QUIT
UPDATE(CRHDFLD,CRHDUSER,CRHDDFN,CRHDTXT) ;
+1 ;SEE NEWDATA
+2 SET CRHDFDA(183.2,"?+1,",.01)=CRHDFLD
+3 SET CRHDFDA(183.21,CRHDUPZZ_CRHDUPZ,.01)=CRHDDFN
+4 SET CRHDFDA(183.21,CRHDUPZZ_CRHDUPZ,3)=CRHDUSER
+5 SET CRHDFDA(183.21,CRHDUPZZ_CRHDUPZ,4)=$$NOW^XLFDT
+6 DO UPDATE^DIE("","CRHDFDA","CRHDOUT","CRHDERR")
+7 SET CRHDIEN=$GET(CRHDOUT(1))
SET CRHDMIEN=$GET(CRHDOUT(2))
+8 LOCK +^CRHD(183.2,CRHDIEN,1,CRHDMIEN):1
IF '$TEST
QUIT
+9 IF '$DATA(CRHDERR)
DO STORETXT(CRHDIEN,CRHDMIEN,.CRHDTXT)
+10 LOCK -^CRHD(183.2,CRHDIEN,1,CRHDMIEN)
+11 QUIT
STORETXT(CRHDIEN,CRHDMIEN,CRHDTARY) ;store text to file
+1 NEW CRHDTRG,CRHDFG,CRHDX,CRHDCT,CRHDLINE
+2 if 'CRHDIEN&('CRHDMIEN)
QUIT
+3 SET CRHDTRG="CRHDTARY"
+4 if '$DATA(@CRHDTRG)
QUIT
+5 ;D SAVEOLD(CRHDIEN,CRHDMIEN)
+6 KILL ^CRHD(183.2,CRHDIEN,1,CRHDMIEN,"TEXT")
+7 SET ^CRHD(183.2,CRHDIEN,1,CRHDMIEN,"TEXT",0)="^^^^"_$$DT^XLFDT
+8 SET CRHDX=0
FOR CRHDLINE=0:1
SET CRHDX=$ORDER(@CRHDTRG@(CRHDX))
if 'CRHDX
QUIT
+9 SET (CRHDFG,CRHDX,CRHDCT)=0
+10 FOR
SET CRHDX=$ORDER(@CRHDTRG@(CRHDX))
if 'CRHDX!(CRHDFG)
QUIT
Begin DoDot:1
+11 IF $DATA(@CRHDTRG@(CRHDX,0))
Begin DoDot:2
+12 MERGE ^CRHD(183.2,CRHDIEN,1,CRHDMIEN,"TEXT")=@CRHDTRG
+13 SET $PIECE(^CRHD(183.2,CRHDIEN,1,CRHDMIEN,"TEXT",0),"^",3,4)=CRHDLINE_"^"_CRHDLINE
+14 SET CRHDFG=1
End DoDot:2
QUIT
+15 IF $GET(@CRHDTRG@(CRHDX))'=""
Begin DoDot:2
+16 SET CRHDCT=CRHDCT+1
+17 SET ^CRHD(183.2,CRHDIEN,1,CRHDMIEN,"TEXT",CRHDCT,0)=@CRHDTRG@(CRHDX)
+18 SET $PIECE(^CRHD(183.2,CRHDIEN,1,CRHDMIEN,"TEXT",0),"^",3,4)=CRHDCT_"^"_CRHDCT
End DoDot:2
End DoDot:1
+19 QUIT
SAVEOLD(CRHDIEN,CRHDMIEN) ;
+1 IF $DATA(^CRHD(183.2,CRHDIEN,1,CRHDMIEN,"TEXT"))
Begin DoDot:1
+2 KILL ^CRHD(183.2,CRHDIEN,1,CRHDMIEN,"ZOLD_TEXT")
+3 MERGE ^CRHD(183.2,CRHDIEN,1,CRHDMIEN,"ZOLD_TEXT")=^CRHD(183.2,CRHDIEN,1,CRHDMIEN,"TEXT")
End DoDot:1
+4 QUIT
CHK(CRHDFLDN,CRHDUSER,CRHDDFN) ;
+1 ;FLG = 1 if record already exist
NEW CRHDFLG,CRHDX,CRHDP
+2 SET CRHDFLG=0
+3 SET CRHDFN=183.2
+4 SET CRHDFLD=$ORDER(^CRHD(CRHDFN,"B",CRHDFLDN,0))
+5 IF $DATA(^CRHD(CRHDFN,"C",+CRHDDFN,+CRHDFLD))
Begin DoDot:1
+6 if CRHDFLD
SET CRHDFLG=1
End DoDot:1
+7 IF CRHDFLG
SET CRHDFLG=CRHDFLG_"^"_CRHDFLD_","
+8 IF '$TEST
SET CRHDFLG=CRHDFLG_"^"_"+1,"
+9 QUIT CRHDFLG
XREF(CRHDIEN,CRHDMIEN) ;SET THE XREF FOR SPECIALTY AND TEAM
+1 NEW CRHDTM,CRHDTSP,CRHDAUTH,CRHDPAT
+2 SET CRHDAUTH=$PIECE($GET(^CRHD(183.2,CRHDIEN,1,CRHDMIEN,0)),"^",2)
+3 if 'CRHDAUTH
QUIT
+4 SET CRHDPAT=$PIECE($GET(^CRHD(183.2,CRHDIEN,1,CRHDMIEN,0)),"^",1)
+5 ;do not set up reference if a private note
+6 if +$PIECE($GET(^CRHD(183.2,CRHDIEN,1,CRHDMIEN,0)),"^",6)
QUIT
+7 SET CRHDTM=$$GET^XPAR("USR.`"_CRHDAUTH,"ORLP DEFAULT TEAM",1,"I")
+8 SET CRHDTSP=$$GET^XPAR("USR.`"_CRHDAUTH,"ORLP DEFAULT SPECIALTY",1,"I")
+9 if +CRHDTM
SET ^CRHD(183.2,"AC","TM",CRHDTM,CRHDPAT,CRHDIEN,CRHDMIEN)=""
+10 if +CRHDTSP
SET ^CRHD(183.2,"AC","TSP",CRHDTSP,CRHDPAT,CRHDIEN,CRHDMIEN)=""
+11 QUIT
KILXREF(CRHDIEN,CRHDMIEN) ;KILL XREF FOR SPECIALTY AND TEAM
+1 NEW CRHDTM,CRHDTSP,CRHDAUTH,CRHDPAT
+2 SET CRHDAUTH=$PIECE($GET(^CRHD(183.2,CRHDIEN,1,CRHDMIEN,0)),"^",2)
+3 if 'CRHDAUTH
QUIT
+4 SET CRHDPAT=$PIECE($GET(^CRHD(183.2,CRHDIEN,1,CRHDMIEN,0)),"^",1)
+5 SET CRHDTM=$$GET^XPAR("USR.`"_CRHDAUTH,"ORLP DEFAULT TEAM",1,"I")
+6 SET CRHDTSP=$$GET^XPAR("USR.`"_CRHDAUTH,"ORLP DEFAULT SPECIALTY",1,"I")
+7 if +CRHDTM
KILL ^CRHD(183.2,"AC","TM",CRHDTM,CRHDPAT,CRHDIEN,CRHDMIEN)
+8 if +CRHDTSP
KILL ^CRHD(183.2,"AC","TSP",CRHDTSP,CRHDPAT,CRHDIEN,CRHDMIEN)
+9 QUIT
ONOFFPRV(CRHDPRIV,CRHDIEN,CRHDMIEN) ;ON/OFF PRIVATE NOTE
+1 IF 'CRHDPRIV
DO XREF(CRHDIEN,CRHDMIEN)
+2 IF +CRHDPRIV
DO KILXREF(CRHDIEN,CRHDMIEN)
+3 QUIT
LOCK(CRHDRTN,CRHDDFN,CRHDFLDM) ;
+1 NEW CRHDIEN,CRHDMIEN
+2 SET CRHDRTN=0
+3 SET CRHDFLDM=$$UP^XLFSTR(CRHDFLDM)
+4 SET CRHDIEN=$ORDER(^CRHD(183.2,"B",CRHDFLDM,0))
+5 SET CRHDMIEN=$ORDER(^CRHD(183.2,"C",+CRHDDFN,+CRHDIEN,0))
+6 if 'CRHDMIEN
QUIT
+7 ;_"^0^Another user is editing this task"
LOCK +^CRHD(183.2,CRHDIEN,1,CRHDMIEN):10
IF '$TEST
SET CRHDRTN=1
+8 LOCK -^CRHD(183.2,CRHDIEN,1,CRHDMIEN)
+9 QUIT
