source: FOIAVistA/tag/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/CRHD2.m@ 1154

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