AGGPOTH ;VNGT/HS/BEE-Other Patient Data Field Handling ; 02 May 2010 9:08 AM
;;1.0;PATIENT REGISTRATION GUI;;Nov 15, 2010
;
Q
;
UMIG(AGPATDFN,NSTS,NTYP) ;PEP - Update Migrant Worker Information
;
;Input:
; AGPATDFN - Patient IEN
; NSTS - New Migrant Status (Y/N)
; NTYP - New Migrant Worker Type (M/S)
;
;Output:
;Returns -1^Error Message - on Failure
; "" - on Success
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^AGGPOTH D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
Q:AGPATDFN="" "-1^Missing Patient IEN"
;
N AGG,DA,DIC,DLAYGO,ERROR,X,Y
;
;Define new entry and save
S DIC="^AUPNPAT("_AGPATDFN_",84,",DA(1)=AGPATDFN
S DIC(0)="L"
S X=DT
S DLAYGO="9000001.84",DIC("P")=DLAYGO
I '$D(^AUPNPAT(AGPATDFN,84,0)) S ^AUPNPAT(AGPATDFN,84,0)="^9000001.84D^^"
K DO,DD D FILE^DICN
;
S DA=+Y,DA(1)=AGPATDFN
S AGG(9000001.84,DA_","_DA(1)_",",".02")=$S(NSTS'="":NSTS,1:"@")
S AGG(9000001.84,DA_","_DA(1)_",",".03")=$S(((NSTS="")!(NSTS="N")):"@",1:NTYP)
D FILE^DIE("","AGG","ERROR")
;
I $D(ERROR) Q "-1^"_$G(ERROR)
;
;Successful Save
Q ""
;
RMIG(AGPATDFN) ;Return the patients most recent Migrant information
;
N MDT,MDTX,MIEN,MSTS,MSTSX,MTYP,MTYPX,Y
;
S (MDT,MDTX,MIEN,MSTS,MSTSX,MTYP,MTYPX)=""
S MDT=$O(^AUPNPAT(AGPATDFN,84,"B",""),-1)
I MDT]"" S MIEN=$O(^AUPNPAT(AGPATDFN,84,"B",MDT,""),-1)
S Y=MDT X ^DD("DD") S MDTX=Y
I MIEN]"" S MSTS=$$GET1^DIQ(9000001.84,MIEN_","_AGPATDFN_",",".02","I")
I MIEN]"" S MTYP=$$GET1^DIQ(9000001.84,MIEN_","_AGPATDFN_",",".03","I")
I MIEN]"" S MSTSX=$$GET1^DIQ(9000001.84,MIEN_","_AGPATDFN_",",".02","E")
I MIEN]"" S MTYPX=$$GET1^DIQ(9000001.84,MIEN_","_AGPATDFN_",",".03","E")
;
Q MIEN_U_MDT_":"_MDTX_U_MSTS_":"_MSTSX_U_MTYP_":"_MTYPX
;
;
UHOM(AGPATDFN,NSTS,NTYP) ;PEP - Update Homeless Information
;
;Input:
; AGPATDFN - Patient IEN
; NSTS - New Homeless Status (Y/N)
; NTYP - New Homeless Type (H/T/D/S/U)
;
;Output:
;Returns -1^Error Message - on Failure
; "" - on Success
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^AGGPOTH D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
Q:AGPATDFN="" "-1^Missing Patient IEN"
;
N AGG,DA,DIC,DLAYGO,ERROR,X,Y
;
;Define new entry and save
S DIC="^AUPNPAT("_AGPATDFN_",85,",DA(1)=AGPATDFN
S DIC(0)="L"
S X=DT
S DLAYGO="9000001.85",DIC("P")=DLAYGO
I '$D(^AUPNPAT(AGPATDFN,85,0)) S ^AUPNPAT(AGPATDFN,85,0)="^9000001.85D^^"
K DO,DD D FILE^DICN
;
S DA=+Y,DA(1)=AGPATDFN
S AGG(9000001.85,DA_","_DA(1)_",",".02")=$S(NSTS'="":NSTS,1:"@")
S AGG(9000001.85,DA_","_DA(1)_",",".03")=$S(((NSTS="")!(NSTS="N")):"@",1:NTYP)
D FILE^DIE("","AGG","ERROR")
;
I $D(ERROR) Q "-1^"_$G(ERROR)
;
;Successful Save
Q ""
;
RHOM(AGPATDFN) ;Return the patients most recent Homeless information
;
N HDT,HDTX,HIEN,HSTS,HSTSX,HTYP,HTYPX,Y
;
S (HDT,HDTX,HIEN,HSTS,HSTSX,HTYP,HTYPX)=""
S HDT=$O(^AUPNPAT(AGPATDFN,85,"B",""),-1)
I HDT]"" S HIEN=$O(^AUPNPAT(AGPATDFN,85,"B",HDT,""),-1)
S Y=HDT X ^DD("DD") S HDTX=Y
I HIEN]"" S HSTS=$$GET1^DIQ(9000001.85,HIEN_","_AGPATDFN_",",".02","I")
I HIEN]"" S HTYP=$$GET1^DIQ(9000001.85,HIEN_","_AGPATDFN_",",".03","I")
I HIEN]"" S HSTSX=$$GET1^DIQ(9000001.85,HIEN_","_AGPATDFN_",",".02","E")
I HIEN]"" S HTYPX=$$GET1^DIQ(9000001.85,HIEN_","_AGPATDFN_",",".03","E")
;
Q HIEN_U_HDT_":"_HDTX_U_HSTS_":"_HSTSX_U_HTYP_":"_HTYPX
;
;
UINT(AGPATDFN,AGGINTNT,OTHPARM) ;PEP - Update Internet Access Information
;
;Input:
; AGPATDFN - Patient IEN
; AGGINTNT - (1-YES/0-NO)
; OTHPARM - OTHER_PARMS return value
;
;Output:
;Returns -1^Error Message - on Failure
; "" - on Success
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^AGGPOTH D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
Q:AGPATDFN="" "-1^Missing Patient IEN"
;
N AGG,DA,DIC,DLAYGO,ERROR,X,Y,LIEN,LDT
;
;Pull existing entry IEN
S LIEN="",LDT=$O(^AUPNPAT(AGPATDFN,81,"B",""),-1)
I LDT]"" S LIEN=$O(^AUPNPAT(AGPATDFN,81,"B",LDT,""),-1)
;
;Define new entry and save
S DIC="^AUPNPAT("_AGPATDFN_",81,",DA(1)=AGPATDFN
S DIC(0)="L"
S X=DT
S DLAYGO="9000001.81",DIC("P")=DLAYGO
I '$D(^AUPNPAT(AGPATDFN,81,0)) S ^AUPNPAT(AGPATDFN,81,0)="^9000001.81D^^"
K DO,DD D FILE^DICN
;
S DA=+Y,DA(1)=AGPATDFN
S OTHPARM=$G(OTHPARM)_$S($G(OTHPARM)'="":$C(28),1:"")_"AGGINT="_+Y
S AGG(9000001.81,DA_","_DA(1)_",",".02")=$S(AGGINTNT=0:0,AGGINTNT=1:1,1:"@")
D FILE^DIE("","AGG","ERROR")
;
I LIEN]"" M ^AUPNPAT(AGPATDFN,81,DA,1)=^AUPNPAT(AGPATDFN,81,LIEN,1)
;
I $D(ERROR) Q "-1^"_$G(ERROR)
;
;Successful Save
Q ""
;
;
ULNG(AGPATDFN,NPRM,NINT,NEPR,NPRF,OTHPARM) ;PEP - Update Language Information
;
;Input:
; AGPATDFN - Patient IEN
; NPRM - Primary Patient Language IEN
; NINT - Interpreter Required (Y/N/U)
; NEPR - English Proficiency (VW/W/NW/NA)
; NPRF - Preferred Patient Language IEN
; OTHPARM - OTHER_PARMS return value
;
;Output:
;Returns -1^Error Message - on Failure
; "" - on Success
; OTHPARM - Delimited parameter containing IEN of new language multiple
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^AGGPOTH D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
Q:AGPATDFN="" "-1^Missing Patient IEN"
;
N AGG,DA,DIC,DLAYGO,ERROR,X,Y,LDT,LIEN
;
;Pull existing entry IEN
S LIEN="",LDT=$O(^AUPNPAT(AGPATDFN,86,"B",""),-1)
I LDT]"" S LIEN=$O(^AUPNPAT(AGPATDFN,86,"B",LDT,""),-1)
;
;Define new entry and save
S DIC="^AUPNPAT("_AGPATDFN_",86,",DA(1)=AGPATDFN
S DIC(0)="L"
S X=DT
S DLAYGO="9000001.86",DIC("P")=DLAYGO
I '$D(^AUPNPAT(AGPATDFN,86,0)) S ^AUPNPAT(AGPATDFN,86,0)="^9000001.86D^^"
K DO,DD D FILE^DICN
;
S DA=+Y,DA(1)=AGPATDFN
S OTHPARM=$G(OTHPARM)_$S($G(OTHPARM)'="":$C(28),1:"")_"AGGLNG="_+Y
I $G(NPRM)]"" S AGG(9000001.86,DA_","_DA(1)_",",".02")=NPRM
I $G(NINT)]"" S AGG(9000001.86,DA_","_DA(1)_",",".03")=NINT
I $G(NPRF)]"" S AGG(9000001.86,DA_","_DA(1)_",",".04")=NPRF
I $G(NEPR)]"" S AGG(9000001.86,DA_","_DA(1)_",",".06")=NEPR
I $D(AGG) D FILE^DIE("","AGG","ERROR")
;
I LIEN]"" M ^AUPNPAT(AGPATDFN,86,DA,5)=^AUPNPAT(AGPATDFN,86,LIEN,5) ;Save Existing Other Spoken Languages
;
I $D(ERROR) Q "-1^"_$G(ERROR)_U_$G(OTHPARM)
;
;Successful Save
Q ""
;
UPD(DATA,DEF,AGPATDFN,MIEN,PROC,PARMS) ; EP - AGG UPDATE SPECIAL MULTIPLES
; Input
; DEF - Definition Name 'Other Languages'
; AGPATDFN - Patient DFN
; MIEN - Multiple Level IEN value
; PROC - 'A' to add, 'D' to delete
; PARMS - Parameters
;
NEW UID,II,LIST,BN,AGGLGOTH,VFIEN,BQ,PDATA,NAME,VALUE,PFIEN,PTYP,CHIEN,RESULT,AGGINAM
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("AGGPOTH",UID))
S MIEN=$G(MIEN,"") S:MIEN=0 MIEN=""
K @DATA
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^AGGPOTH D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
S @DATA@(II)="I00010RESULT^T01024ERROR"_$C(30)
;
S PARMS=$G(PARMS,"")
I PARMS="" D
. S LIST="",BN=""
. F S BN=$O(PARMS(BN)) Q:BN="" S LIST=LIST_PARMS(BN)
. K PARMS
. S PARMS=LIST
. K LIST
;
S AGGLGOTH="",AGGINAM=""
S VFIEN=$O(^AGG(9009068.3,"B",DEF,""))
I VFIEN="" S BMXSEC="RPC Call Failed: "_DEF_" Definition does not exist." Q
;
F BQ=1:1:$L(PARMS,$C(28)) D Q:$G(BMXSEC)'=""
. S PDATA=$P(PARMS,$C(28),BQ) Q:PDATA=""
. S NAME=$P(PDATA,"=",1),VALUE=$P(PDATA,"=",2,99)
. S PFIEN=$O(^AGG(9009068.3,VFIEN,10,"AC",NAME,""))
. I PFIEN="" S BMXSEC=NAME_" not a valid parameter for this update" Q
. S PTYP=$P($G(^AGG(9009068.3,VFIEN,10,PFIEN,1)),U,1)
. I PTYP="D" S VALUE=$$DATE^AGGUL1(VALUE)
. I PTYP="C" D
.. I VALUE="" Q
.. S CHIEN=$O(^AGG(9009068.3,VFIEN,10,PFIEN,5,"B",VALUE,"")) I CHIEN="" Q
.. S VALUE=$P(^AGG(9009068.3,VFIEN,10,PFIEN,5,CHIEN,0),U,2)
. S @NAME=VALUE
;
S RESULT="-1^Unable to save multiple entry "_AGGLGOTH
;
;Process 'Other Languages' entries
I DEF="Other Languages" D
. ;
. ;Set up for Adds
. I $G(PROC)="A",$G(AGGLGOTH)]"" D Q
.. N FDAIEN,FDA,ERROR
.. S FDAIEN(1)=AGGLGOTH
.. S FDA(1,9000001.8605,"+1,"_MIEN_","_AGPATDFN_",",.01)=AGGLGOTH
.. D UPDATE^DIE("","FDA(1)","FDAIEN","ERROR")
.. I $D(ERROR) S RESULT="-1^"_$G(ERROR("DIERR",1,"TEXT",1)) Q
.. S RESULT="1^"
.. ;
. ;Handle Deletes
. I $G(PROC)="D" D Q
.. N DA,AGG,ERROR
.. S DA=+AGGLGOTH,DA(1)=MIEN,DA(2)=AGPATDFN
.. S AGG(9000001.8605,DA_","_DA(1)_","_DA(2)_",",.01)="@"
.. D FILE^DIE("","AGG","ERROR")
.. I $D(ERROR) S RESULT="-1^"_$G(ERROR("DIERR",1,"TEXT",1)) Q
.. S RESULT="1^"
;
;Process 'Internet Access Method' entries
I DEF="Internet Access Method" D
. ;
. ;Set up for Adds
. I $G(PROC)="A",$G(AGGINAM)]"" D Q
.. N FDA,ERROR
.. S FDA(1,9000001.811,"+1,"_MIEN_","_AGPATDFN_",",.01)=AGGINAM
.. D UPDATE^DIE("","FDA(1)","","ERROR")
.. I $D(ERROR) S RESULT="-1^"_$G(ERROR("DIERR",1,"TEXT",1)) Q
.. S RESULT="1^"
. ;
. ;Handle Deletes
. I $G(PROC)="D" D Q
.. N DA,AGG,ERROR
.. S DA=$O(^AUPNPAT(AGPATDFN,81,MIEN,1,"B",AGGINAM,"")) Q:DA=""
.. S DA(1)=MIEN,DA(2)=AGPATDFN
.. S AGG(9000001.811,DA_","_DA(1)_","_DA(2)_",",.01)="@"
.. D FILE^DIE("","AGG","ERROR")
.. I $D(ERROR) S RESULT="-1^"_$G(ERROR("DIERR",1,"TEXT",1)) Q
.. S RESULT="1^"
;
DONE ;
S II=II+1,@DATA@(II)=RESULT_$C(30)
S II=II+1,@DATA@(II)=$C(31)
;
; Set last date updated and updated by
I $P(RESULT,U,1)=1 D
. S AGGDATAI(9000001,AGPATDFN_",",.03)=DT,AGGDATAI(9000001,AGPATDFN_",",.12)=DUZ
. D FILE^DIE("I","AGGDATAI","ERROR")
. D EDIT^AGGEXPRT(AGPATDFN)
Q
;
INTAM(DATA,DFN) ; EP - AGG PATIENT INT ACCESS METH
;
NEW UID,II,AGIEN,ERROR,FILE,HEADR,DA,IDA,IEN,IENS
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("AGGPOTH",UID))
K @DATA
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^AGGPOTH D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S AGIEN=$$FIND1^DIC(9009068.3,"","BX","Internet Access Method","","","ERROR")
I AGIEN=0 S BMXSEC="RPC Failed: Passed in window name "_DEF_" not found" Q
;
S FILE=$P(^AGG(9009068.3,AGIEN,0),U,2),SECFILE=$P(^AGG(9009068.3,AGIEN,0),U,14)
;
S DA(1)=DFN,IDA=$O(^AUPNPAT(DFN,81,"B"),-1) I IDA="" D G XINTAM
. N HEADR
. S HEADR="T00050AGGINAM"
. S @DATA@(II)=HEADR_$C(30)
;
I $O(^AUPNPAT(DFN,81,IDA,1,0))="" D G XINTAM
. N HEADR
. S HEADR="T00050AGGINAM"
. S @DATA@(II)=HEADR_$C(30)
;
S IEN=0 F S IEN=$O(^AUPNPAT(DFN,81,IDA,1,IEN)) Q:'IEN D
. S DA(2)=DFN,DA(1)=IDA,DA=IEN
. S IENS=$$IENS^DILF(.DA)
. D REC(IENS,FILE,SECFILE)
;
XINTAM ;
S II=II+1,@DATA@(II)=$C(31)
;
Q
;
REC(IENS,FILE,SECFILE) ;EP
N AGCN,HEADR,HDATA,HDR,TXT
S HEADR="",HDATA=""
S AGCN=0
F S AGCN=$O(^AGG(9009068.3,AGIEN,10,AGCN)) Q:'AGCN D
. N AGDATA,FLD,TYPE,SECFLD,CODE,DEXEC,VAL,DQTY,FLD,VALUE
. I $P(^AGG(9009068.3,AGIEN,10,AGCN,0),U,11)'="" Q
. S AGDATA=$G(^AGG(9009068.3,AGIEN,10,AGCN,0))
. S FLD=$P($G(^AGG(9009068.3,AGIEN,10,AGCN,3)),U,1),SECFLD=$P($G(^AGG(9009068.3,AGIEN,10,AGCN,3)),U,7)
. S TYPE=$P($G(^AGG(9009068.3,AGIEN,10,AGCN,1)),U,1)
. S CODE=$P(AGDATA,U,7),HDR=$P(AGDATA,U,2)
. S DEXEC=$G(^AGG(9009068.3,AGIEN,10,AGCN,8))
. I TYPE="M" S VALUE=""
. I TYPE="T"!(TYPE="C")!(TYPE="K") D
.. I DEXEC'="" D Q
... S VAL=""
... I DEXEC'["DQTY" X DEXEC Q
... S DQTY="I" X DEXEC S VAL=VALUE_$C(28)
... S DQTY="E" X DEXEC S VALUE=VAL_VALUE
.. I FLD'="" S VALUE=$$GET1^DIQ(FILE,IENS,FLD,"I")_$C(28)_$$GET1^DIQ(FILE,IENS,FLD,"E") Q
.. S VALUE=$$GET1^DIQ(SECFILE,IENS,SECFLD,"I")_$C(28)_$$GET1^DIQ(SECFILE,IENS,SECFLD,"E")
. I TYPE="X"!(TYPE="N") D
.. NEW TYPE
.. I DEXEC'="" X DEXEC Q
.. I FLD=.001 S VALUE=IEN Q
.. I FLD'="" S VALUE=$$GET1^DIQ(FILE,IENS,FLD,"E") Q
.. S VALUE=$$GET1^DIQ(SECFILE,IENS,SECFLD,"E")
. I TYPE="D" D
.. I DEXEC'="" X DEXEC Q
.. I FLD'="" S VALUE=$$GET1^DIQ(FILE,IENS,FLD,"I"),VALUE=$$FMTE^AGGUL1(VALUE) Q
.. S VALUE=$$GET1^DIQ(SECFILE,IENS,SECFLD,"I"),VALUE=$$FMTE^AGGUL1(VALUE)
. I TYPE="W" D
.. NEW FL,FD,AN
.. K ARRAY S VALUE=""
.. I DEXEC'="" X DEXEC
.. I DEXEC="" D
... I FLD'="" D GETS^DIQ(FILE,DFN_",",FLD,"E","ARRAY") Q
... D GETS^DIQ(SECFILE,DFN_",",SECFLD,"E","ARRAY")
.. S FL=$O(ARRAY("")) I FL="" Q
.. S FD=$O(ARRAY(FL,DFN_",","")) I FD="" Q
.. S AN=0,TXT=ARRAY(FL,DFN_",",FD,"E") I TXT="" Q
.. K @TXT@("E")
.. F S AN=$O(@TXT@(AN)) Q:AN="" S VALUE=VALUE_@TXT@(AN)_$C(10)
. S HEADR=HEADR_HDR_"^"
. S HDATA=HDATA_$G(VALUE)_"^",VALUE=""
S HEADR=$$TKO^AGGUL1(HEADR,"^"),HDATA=$$TKO^AGGUL1(HDATA,"^")
I II=0 S @DATA@(II)=HEADR_$C(30)
S II=II+1,@DATA@(II)=HDATA_$C(30)
;
Q
;
DOTH(AGPATDFN) ;EP - Return the list of Other Languages Spoken
;
N OTHL,LIEN,LDT,LNG,VAR
;
I AGPATDFN="" Q "" ;Missing patient DFN
;
S OTHL=""
;
;Pull existing entry IEN
S LIEN="",LDT=$O(^AUPNPAT(AGPATDFN,86,"B",""),-1)
I LDT]"" S LIEN=$O(^AUPNPAT(AGPATDFN,86,"B",LDT,""),-1)
;
I LIEN="" Q "" ;No Language Information on File
;
;Pull Other Languages
D GETS^DIQ(9000001.86,LIEN_","_AGPATDFN_",",".05*","E","VAR")
;
S IEN="" F S IEN=$O(VAR(9000001.8605,IEN)) Q:IEN="" S LNG=$G(VAR(9000001.8605,IEN,".01","E")) I LNG]"" S OTHL=OTHL_$S(OTHL="":"",1:", ")_LNG I OTHL[", " S OTHL="MORE THAN ONE LANGUAGE" Q
Q OTHL
;
DINTW(AGPATDFN) ;EP - Return the list of Internet WHERE values
;
N INTW,LIEN,LDT,WHERE,VAR,IEN
;
I AGPATDFN="" Q "" ;Missing patient DFN
;
S INTW=""
;
;Pull existing entry IEN
S LIEN="",LDT=$O(^AUPNPAT(AGPATDFN,81,"B",""),-1)
I LDT]"" S LIEN=$O(^AUPNPAT(AGPATDFN,81,"B",LDT,""),-1)
;
I LIEN="" Q "" ;No Internet Information on File
;
;Pull Internet WHERE values
D GETS^DIQ(9000001.81,LIEN_","_AGPATDFN_",",".04*","I","VAR")
;
S IEN="" F S IEN=$O(VAR(9000001.811,IEN)) Q:IEN="" S WHERE=$G(VAR(9000001.811,IEN,".01","I")) I WHERE]"" S INTW=INTW_$S(INTW="":"",1:", ")_WHERE
Q INTW
;
ERR ;
D ^%ZTER
NEW Y,ERRDTM
S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
S BMXSEC="Recording that an error occurred at "_ERRDTM
I $D(II),$D(DATA) S II=II+1,@DATA@(II)=$C(31)
Q
AGGPOTH ;VNGT/HS/BEE-Other Patient Data Field Handling ; 02 May 2010 9:08 AM
+1 ;;1.0;PATIENT REGISTRATION GUI;;Nov 15, 2010
+2 ;
+3 QUIT
+4 ;
UMIG(AGPATDFN,NSTS,NTYP) ;PEP - Update Migrant Worker Information
+1 ;
+2 ;Input:
+3 ; AGPATDFN - Patient IEN
+4 ; NSTS - New Migrant Status (Y/N)
+5 ; NTYP - New Migrant Worker Type (M/S)
+6 ;
+7 ;Output:
+8 ;Returns -1^Error Message - on Failure
+9 ; "" - on Success
+10 ;
+11 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^AGGPOTH D UNWIND^%ZTER"
+12 ;
+13 IF AGPATDFN=""
QUIT "-1^Missing Patient IEN"
+14 ;
+15 NEW AGG,DA,DIC,DLAYGO,ERROR,X,Y
+16 ;
+17 ;Define new entry and save
+18 SET DIC="^AUPNPAT("_AGPATDFN_",84,"
SET DA(1)=AGPATDFN
+19 SET DIC(0)="L"
+20 SET X=DT
+21 SET DLAYGO="9000001.84"
SET DIC("P")=DLAYGO
+22 IF '$DATA(^AUPNPAT(AGPATDFN,84,0))
SET ^AUPNPAT(AGPATDFN,84,0)="^9000001.84D^^"
+23 KILL DO,DD
DO FILE^DICN
+24 ;
+25 SET DA=+Y
SET DA(1)=AGPATDFN
+26 SET AGG(9000001.84,DA_","_DA(1)_",",".02")=$SELECT(NSTS'="":NSTS,1:"@")
+27 SET AGG(9000001.84,DA_","_DA(1)_",",".03")=$SELECT(((NSTS="")!(NSTS="N")):"@",1:NTYP)
+28 DO FILE^DIE("","AGG","ERROR")
+29 ;
+30 IF $DATA(ERROR)
QUIT "-1^"_$GET(ERROR)
+31 ;
+32 ;Successful Save
+33 QUIT ""
+34 ;
RMIG(AGPATDFN) ;Return the patients most recent Migrant information
+1 ;
+2 NEW MDT,MDTX,MIEN,MSTS,MSTSX,MTYP,MTYPX,Y
+3 ;
+4 SET (MDT,MDTX,MIEN,MSTS,MSTSX,MTYP,MTYPX)=""
+5 SET MDT=$ORDER(^AUPNPAT(AGPATDFN,84,"B",""),-1)
+6 IF MDT]""
SET MIEN=$ORDER(^AUPNPAT(AGPATDFN,84,"B",MDT,""),-1)
+7 SET Y=MDT
XECUTE ^DD("DD")
SET MDTX=Y
+8 IF MIEN]""
SET MSTS=$$GET1^DIQ(9000001.84,MIEN_","_AGPATDFN_",",".02","I")
+9 IF MIEN]""
SET MTYP=$$GET1^DIQ(9000001.84,MIEN_","_AGPATDFN_",",".03","I")
+10 IF MIEN]""
SET MSTSX=$$GET1^DIQ(9000001.84,MIEN_","_AGPATDFN_",",".02","E")
+11 IF MIEN]""
SET MTYPX=$$GET1^DIQ(9000001.84,MIEN_","_AGPATDFN_",",".03","E")
+12 ;
+13 QUIT MIEN_U_MDT_":"_MDTX_U_MSTS_":"_MSTSX_U_MTYP_":"_MTYPX
+14 ;
+15 ;
UHOM(AGPATDFN,NSTS,NTYP) ;PEP - Update Homeless Information
+1 ;
+2 ;Input:
+3 ; AGPATDFN - Patient IEN
+4 ; NSTS - New Homeless Status (Y/N)
+5 ; NTYP - New Homeless Type (H/T/D/S/U)
+6 ;
+7 ;Output:
+8 ;Returns -1^Error Message - on Failure
+9 ; "" - on Success
+10 ;
+11 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^AGGPOTH D UNWIND^%ZTER"
+12 ;
+13 IF AGPATDFN=""
QUIT "-1^Missing Patient IEN"
+14 ;
+15 NEW AGG,DA,DIC,DLAYGO,ERROR,X,Y
+16 ;
+17 ;Define new entry and save
+18 SET DIC="^AUPNPAT("_AGPATDFN_",85,"
SET DA(1)=AGPATDFN
+19 SET DIC(0)="L"
+20 SET X=DT
+21 SET DLAYGO="9000001.85"
SET DIC("P")=DLAYGO
+22 IF '$DATA(^AUPNPAT(AGPATDFN,85,0))
SET ^AUPNPAT(AGPATDFN,85,0)="^9000001.85D^^"
+23 KILL DO,DD
DO FILE^DICN
+24 ;
+25 SET DA=+Y
SET DA(1)=AGPATDFN
+26 SET AGG(9000001.85,DA_","_DA(1)_",",".02")=$SELECT(NSTS'="":NSTS,1:"@")
+27 SET AGG(9000001.85,DA_","_DA(1)_",",".03")=$SELECT(((NSTS="")!(NSTS="N")):"@",1:NTYP)
+28 DO FILE^DIE("","AGG","ERROR")
+29 ;
+30 IF $DATA(ERROR)
QUIT "-1^"_$GET(ERROR)
+31 ;
+32 ;Successful Save
+33 QUIT ""
+34 ;
RHOM(AGPATDFN) ;Return the patients most recent Homeless information
+1 ;
+2 NEW HDT,HDTX,HIEN,HSTS,HSTSX,HTYP,HTYPX,Y
+3 ;
+4 SET (HDT,HDTX,HIEN,HSTS,HSTSX,HTYP,HTYPX)=""
+5 SET HDT=$ORDER(^AUPNPAT(AGPATDFN,85,"B",""),-1)
+6 IF HDT]""
SET HIEN=$ORDER(^AUPNPAT(AGPATDFN,85,"B",HDT,""),-1)
+7 SET Y=HDT
XECUTE ^DD("DD")
SET HDTX=Y
+8 IF HIEN]""
SET HSTS=$$GET1^DIQ(9000001.85,HIEN_","_AGPATDFN_",",".02","I")
+9 IF HIEN]""
SET HTYP=$$GET1^DIQ(9000001.85,HIEN_","_AGPATDFN_",",".03","I")
+10 IF HIEN]""
SET HSTSX=$$GET1^DIQ(9000001.85,HIEN_","_AGPATDFN_",",".02","E")
+11 IF HIEN]""
SET HTYPX=$$GET1^DIQ(9000001.85,HIEN_","_AGPATDFN_",",".03","E")
+12 ;
+13 QUIT HIEN_U_HDT_":"_HDTX_U_HSTS_":"_HSTSX_U_HTYP_":"_HTYPX
+14 ;
+15 ;
UINT(AGPATDFN,AGGINTNT,OTHPARM) ;PEP - Update Internet Access Information
+1 ;
+2 ;Input:
+3 ; AGPATDFN - Patient IEN
+4 ; AGGINTNT - (1-YES/0-NO)
+5 ; OTHPARM - OTHER_PARMS return value
+6 ;
+7 ;Output:
+8 ;Returns -1^Error Message - on Failure
+9 ; "" - on Success
+10 ;
+11 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^AGGPOTH D UNWIND^%ZTER"
+12 ;
+13 IF AGPATDFN=""
QUIT "-1^Missing Patient IEN"
+14 ;
+15 NEW AGG,DA,DIC,DLAYGO,ERROR,X,Y,LIEN,LDT
+16 ;
+17 ;Pull existing entry IEN
+18 SET LIEN=""
SET LDT=$ORDER(^AUPNPAT(AGPATDFN,81,"B",""),-1)
+19 IF LDT]""
SET LIEN=$ORDER(^AUPNPAT(AGPATDFN,81,"B",LDT,""),-1)
+20 ;
+21 ;Define new entry and save
+22 SET DIC="^AUPNPAT("_AGPATDFN_",81,"
SET DA(1)=AGPATDFN
+23 SET DIC(0)="L"
+24 SET X=DT
+25 SET DLAYGO="9000001.81"
SET DIC("P")=DLAYGO
+26 IF '$DATA(^AUPNPAT(AGPATDFN,81,0))
SET ^AUPNPAT(AGPATDFN,81,0)="^9000001.81D^^"
+27 KILL DO,DD
DO FILE^DICN
+28 ;
+29 SET DA=+Y
SET DA(1)=AGPATDFN
+30 SET OTHPARM=$GET(OTHPARM)_$SELECT($GET(OTHPARM)'="":$CHAR(28),1:"")_"AGGINT="_+Y
+31 SET AGG(9000001.81,DA_","_DA(1)_",",".02")=$SELECT(AGGINTNT=0:0,AGGINTNT=1:1,1:"@")
+32 DO FILE^DIE("","AGG","ERROR")
+33 ;
+34 IF LIEN]""
MERGE ^AUPNPAT(AGPATDFN,81,DA,1)=^AUPNPAT(AGPATDFN,81,LIEN,1)
+35 ;
+36 IF $DATA(ERROR)
QUIT "-1^"_$GET(ERROR)
+37 ;
+38 ;Successful Save
+39 QUIT ""
+40 ;
+41 ;
ULNG(AGPATDFN,NPRM,NINT,NEPR,NPRF,OTHPARM) ;PEP - Update Language Information
+1 ;
+2 ;Input:
+3 ; AGPATDFN - Patient IEN
+4 ; NPRM - Primary Patient Language IEN
+5 ; NINT - Interpreter Required (Y/N/U)
+6 ; NEPR - English Proficiency (VW/W/NW/NA)
+7 ; NPRF - Preferred Patient Language IEN
+8 ; OTHPARM - OTHER_PARMS return value
+9 ;
+10 ;Output:
+11 ;Returns -1^Error Message - on Failure
+12 ; "" - on Success
+13 ; OTHPARM - Delimited parameter containing IEN of new language multiple
+14 ;
+15 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^AGGPOTH D UNWIND^%ZTER"
+16 ;
+17 IF AGPATDFN=""
QUIT "-1^Missing Patient IEN"
+18 ;
+19 NEW AGG,DA,DIC,DLAYGO,ERROR,X,Y,LDT,LIEN
+20 ;
+21 ;Pull existing entry IEN
+22 SET LIEN=""
SET LDT=$ORDER(^AUPNPAT(AGPATDFN,86,"B",""),-1)
+23 IF LDT]""
SET LIEN=$ORDER(^AUPNPAT(AGPATDFN,86,"B",LDT,""),-1)
+24 ;
+25 ;Define new entry and save
+26 SET DIC="^AUPNPAT("_AGPATDFN_",86,"
SET DA(1)=AGPATDFN
+27 SET DIC(0)="L"
+28 SET X=DT
+29 SET DLAYGO="9000001.86"
SET DIC("P")=DLAYGO
+30 IF '$DATA(^AUPNPAT(AGPATDFN,86,0))
SET ^AUPNPAT(AGPATDFN,86,0)="^9000001.86D^^"
+31 KILL DO,DD
DO FILE^DICN
+32 ;
+33 SET DA=+Y
SET DA(1)=AGPATDFN
+34 SET OTHPARM=$GET(OTHPARM)_$SELECT($GET(OTHPARM)'="":$CHAR(28),1:"")_"AGGLNG="_+Y
+35 IF $GET(NPRM)]""
SET AGG(9000001.86,DA_","_DA(1)_",",".02")=NPRM
+36 IF $GET(NINT)]""
SET AGG(9000001.86,DA_","_DA(1)_",",".03")=NINT
+37 IF $GET(NPRF)]""
SET AGG(9000001.86,DA_","_DA(1)_",",".04")=NPRF
+38 IF $GET(NEPR)]""
SET AGG(9000001.86,DA_","_DA(1)_",",".06")=NEPR
+39 IF $DATA(AGG)
DO FILE^DIE("","AGG","ERROR")
+40 ;
+41 ;Save Existing Other Spoken Languages
IF LIEN]""
MERGE ^AUPNPAT(AGPATDFN,86,DA,5)=^AUPNPAT(AGPATDFN,86,LIEN,5)
+42 ;
+43 IF $DATA(ERROR)
QUIT "-1^"_$GET(ERROR)_U_$GET(OTHPARM)
+44 ;
+45 ;Successful Save
+46 QUIT ""
+47 ;
UPD(DATA,DEF,AGPATDFN,MIEN,PROC,PARMS) ; EP - AGG UPDATE SPECIAL MULTIPLES
+1 ; Input
+2 ; DEF - Definition Name 'Other Languages'
+3 ; AGPATDFN - Patient DFN
+4 ; MIEN - Multiple Level IEN value
+5 ; PROC - 'A' to add, 'D' to delete
+6 ; PARMS - Parameters
+7 ;
+8 NEW UID,II,LIST,BN,AGGLGOTH,VFIEN,BQ,PDATA,NAME,VALUE,PFIEN,PTYP,CHIEN,RESULT,AGGINAM
+9 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+10 SET DATA=$NAME(^TMP("AGGPOTH",UID))
+11 SET MIEN=$GET(MIEN,"")
IF MIEN=0
SET MIEN=""
+12 KILL @DATA
+13 ;
+14 SET II=0
+15 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^AGGPOTH D UNWIND^%ZTER"
+16 SET @DATA@(II)="I00010RESULT^T01024ERROR"_$CHAR(30)
+17 ;
+18 SET PARMS=$GET(PARMS,"")
+19 IF PARMS=""
Begin DoDot:1
+20 SET LIST=""
SET BN=""
+21 FOR
SET BN=$ORDER(PARMS(BN))
IF BN=""
QUIT
SET LIST=LIST_PARMS(BN)
+22 KILL PARMS
+23 SET PARMS=LIST
+24 KILL LIST
End DoDot:1
+25 ;
+26 SET AGGLGOTH=""
SET AGGINAM=""
+27 SET VFIEN=$ORDER(^AGG(9009068.3,"B",DEF,""))
+28 IF VFIEN=""
SET BMXSEC="RPC Call Failed: "_DEF_" Definition does not exist."
QUIT
+29 ;
+30 FOR BQ=1:1:$LENGTH(PARMS,$CHAR(28))
Begin DoDot:1
+31 SET PDATA=$PIECE(PARMS,$CHAR(28),BQ)
IF PDATA=""
QUIT
+32 SET NAME=$PIECE(PDATA,"=",1)
SET VALUE=$PIECE(PDATA,"=",2,99)
+33 SET PFIEN=$ORDER(^AGG(9009068.3,VFIEN,10,"AC",NAME,""))
+34 IF PFIEN=""
SET BMXSEC=NAME_" not a valid parameter for this update"
QUIT
+35 SET PTYP=$PIECE($GET(^AGG(9009068.3,VFIEN,10,PFIEN,1)),U,1)
+36 IF PTYP="D"
SET VALUE=$$DATE^AGGUL1(VALUE)
+37 IF PTYP="C"
Begin DoDot:2
+38 IF VALUE=""
QUIT
+39 SET CHIEN=$ORDER(^AGG(9009068.3,VFIEN,10,PFIEN,5,"B",VALUE,""))
IF CHIEN=""
QUIT
+40 SET VALUE=$PIECE(^AGG(9009068.3,VFIEN,10,PFIEN,5,CHIEN,0),U,2)
End DoDot:2
+41 SET @NAME=VALUE
End DoDot:1
IF $GET(BMXSEC)'=""
QUIT
+42 ;
+43 SET RESULT="-1^Unable to save multiple entry "_AGGLGOTH
+44 ;
+45 ;Process 'Other Languages' entries
+46 IF DEF="Other Languages"
Begin DoDot:1
+47 ;
+48 ;Set up for Adds
+49 IF $GET(PROC)="A"
IF $GET(AGGLGOTH)]""
Begin DoDot:2
+50 NEW FDAIEN,FDA,ERROR
+51 SET FDAIEN(1)=AGGLGOTH
+52 SET FDA(1,9000001.8605,"+1,"_MIEN_","_AGPATDFN_",",.01)=AGGLGOTH
+53 DO UPDATE^DIE("","FDA(1)","FDAIEN","ERROR")
+54 IF $DATA(ERROR)
SET RESULT="-1^"_$GET(ERROR("DIERR",1,"TEXT",1))
QUIT
+55 SET RESULT="1^"
+56 ;
End DoDot:2
QUIT
+57 ;Handle Deletes
+58 IF $GET(PROC)="D"
Begin DoDot:2
+59 NEW DA,AGG,ERROR
+60 SET DA=+AGGLGOTH
SET DA(1)=MIEN
SET DA(2)=AGPATDFN
+61 SET AGG(9000001.8605,DA_","_DA(1)_","_DA(2)_",",.01)="@"
+62 DO FILE^DIE("","AGG","ERROR")
+63 IF $DATA(ERROR)
SET RESULT="-1^"_$GET(ERROR("DIERR",1,"TEXT",1))
QUIT
+64 SET RESULT="1^"
End DoDot:2
QUIT
End DoDot:1
+65 ;
+66 ;Process 'Internet Access Method' entries
+67 IF DEF="Internet Access Method"
Begin DoDot:1
+68 ;
+69 ;Set up for Adds
+70 IF $GET(PROC)="A"
IF $GET(AGGINAM)]""
Begin DoDot:2
+71 NEW FDA,ERROR
+72 SET FDA(1,9000001.811,"+1,"_MIEN_","_AGPATDFN_",",.01)=AGGINAM
+73 DO UPDATE^DIE("","FDA(1)","","ERROR")
+74 IF $DATA(ERROR)
SET RESULT="-1^"_$GET(ERROR("DIERR",1,"TEXT",1))
QUIT
+75 SET RESULT="1^"
End DoDot:2
QUIT
+76 ;
+77 ;Handle Deletes
+78 IF $GET(PROC)="D"
Begin DoDot:2
+79 NEW DA,AGG,ERROR
+80 SET DA=$ORDER(^AUPNPAT(AGPATDFN,81,MIEN,1,"B",AGGINAM,""))
IF DA=""
QUIT
+81 SET DA(1)=MIEN
SET DA(2)=AGPATDFN
+82 SET AGG(9000001.811,DA_","_DA(1)_","_DA(2)_",",.01)="@"
+83 DO FILE^DIE("","AGG","ERROR")
+84 IF $DATA(ERROR)
SET RESULT="-1^"_$GET(ERROR("DIERR",1,"TEXT",1))
QUIT
+85 SET RESULT="1^"
End DoDot:2
QUIT
End DoDot:1
+86 ;
DONE ;
+1 SET II=II+1
SET @DATA@(II)=RESULT_$CHAR(30)
+2 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+3 ;
+4 ; Set last date updated and updated by
+5 IF $PIECE(RESULT,U,1)=1
Begin DoDot:1
+6 SET AGGDATAI(9000001,AGPATDFN_",",.03)=DT
SET AGGDATAI(9000001,AGPATDFN_",",.12)=DUZ
+7 DO FILE^DIE("I","AGGDATAI","ERROR")
+8 DO EDIT^AGGEXPRT(AGPATDFN)
End DoDot:1
+9 QUIT
+10 ;
INTAM(DATA,DFN) ; EP - AGG PATIENT INT ACCESS METH
+1 ;
+2 NEW UID,II,AGIEN,ERROR,FILE,HEADR,DA,IDA,IEN,IENS
+3 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+4 SET DATA=$NAME(^TMP("AGGPOTH",UID))
+5 KILL @DATA
+6 SET II=0
+7 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^AGGPOTH D UNWIND^%ZTER"
+8 ;
+9 SET AGIEN=$$FIND1^DIC(9009068.3,"","BX","Internet Access Method","","","ERROR")
+10 IF AGIEN=0
SET BMXSEC="RPC Failed: Passed in window name "_DEF_" not found"
QUIT
+11 ;
+12 SET FILE=$PIECE(^AGG(9009068.3,AGIEN,0),U,2)
SET SECFILE=$PIECE(^AGG(9009068.3,AGIEN,0),U,14)
+13 ;
+14 SET DA(1)=DFN
SET IDA=$ORDER(^AUPNPAT(DFN,81,"B"),-1)
IF IDA=""
Begin DoDot:1
+15 NEW HEADR
+16 SET HEADR="T00050AGGINAM"
+17 SET @DATA@(II)=HEADR_$CHAR(30)
End DoDot:1
GOTO XINTAM
+18 ;
+19 IF $ORDER(^AUPNPAT(DFN,81,IDA,1,0))=""
Begin DoDot:1
+20 NEW HEADR
+21 SET HEADR="T00050AGGINAM"
+22 SET @DATA@(II)=HEADR_$CHAR(30)
End DoDot:1
GOTO XINTAM
+23 ;
+24 SET IEN=0
FOR
SET IEN=$ORDER(^AUPNPAT(DFN,81,IDA,1,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+25 SET DA(2)=DFN
SET DA(1)=IDA
SET DA=IEN
+26 SET IENS=$$IENS^DILF(.DA)
+27 DO REC(IENS,FILE,SECFILE)
End DoDot:1
+28 ;
XINTAM ;
+1 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+2 ;
+3 QUIT
+4 ;
REC(IENS,FILE,SECFILE) ;EP
+1 NEW AGCN,HEADR,HDATA,HDR,TXT
+2 SET HEADR=""
SET HDATA=""
+3 SET AGCN=0
+4 FOR
SET AGCN=$ORDER(^AGG(9009068.3,AGIEN,10,AGCN))
IF 'AGCN
QUIT
Begin DoDot:1
+5 NEW AGDATA,FLD,TYPE,SECFLD,CODE,DEXEC,VAL,DQTY,FLD,VALUE
+6 IF $PIECE(^AGG(9009068.3,AGIEN,10,AGCN,0),U,11)'=""
QUIT
+7 SET AGDATA=$GET(^AGG(9009068.3,AGIEN,10,AGCN,0))
+8 SET FLD=$PIECE($GET(^AGG(9009068.3,AGIEN,10,AGCN,3)),U,1)
SET SECFLD=$PIECE($GET(^AGG(9009068.3,AGIEN,10,AGCN,3)),U,7)
+9 SET TYPE=$PIECE($GET(^AGG(9009068.3,AGIEN,10,AGCN,1)),U,1)
+10 SET CODE=$PIECE(AGDATA,U,7)
SET HDR=$PIECE(AGDATA,U,2)
+11 SET DEXEC=$GET(^AGG(9009068.3,AGIEN,10,AGCN,8))
+12 IF TYPE="M"
SET VALUE=""
+13 IF TYPE="T"!(TYPE="C")!(TYPE="K")
Begin DoDot:2
+14 IF DEXEC'=""
Begin DoDot:3
+15 SET VAL=""
+16 IF DEXEC'["DQTY"
XECUTE DEXEC
QUIT
+17 SET DQTY="I"
XECUTE DEXEC
SET VAL=VALUE_$CHAR(28)
+18 SET DQTY="E"
XECUTE DEXEC
SET VALUE=VAL_VALUE
End DoDot:3
QUIT
+19 IF FLD'=""
SET VALUE=$$GET1^DIQ(FILE,IENS,FLD,"I")_$CHAR(28)_$$GET1^DIQ(FILE,IENS,FLD,"E")
QUIT
+20 SET VALUE=$$GET1^DIQ(SECFILE,IENS,SECFLD,"I")_$CHAR(28)_$$GET1^DIQ(SECFILE,IENS,SECFLD,"E")
End DoDot:2
+21 IF TYPE="X"!(TYPE="N")
Begin DoDot:2
+22 NEW TYPE
+23 IF DEXEC'=""
XECUTE DEXEC
QUIT
+24 IF FLD=.001
SET VALUE=IEN
QUIT
+25 IF FLD'=""
SET VALUE=$$GET1^DIQ(FILE,IENS,FLD,"E")
QUIT
+26 SET VALUE=$$GET1^DIQ(SECFILE,IENS,SECFLD,"E")
End DoDot:2
+27 IF TYPE="D"
Begin DoDot:2
+28 IF DEXEC'=""
XECUTE DEXEC
QUIT
+29 IF FLD'=""
SET VALUE=$$GET1^DIQ(FILE,IENS,FLD,"I")
SET VALUE=$$FMTE^AGGUL1(VALUE)
QUIT
+30 SET VALUE=$$GET1^DIQ(SECFILE,IENS,SECFLD,"I")
SET VALUE=$$FMTE^AGGUL1(VALUE)
End DoDot:2
+31 IF TYPE="W"
Begin DoDot:2
+32 NEW FL,FD,AN
+33 KILL ARRAY
SET VALUE=""
+34 IF DEXEC'=""
XECUTE DEXEC
+35 IF DEXEC=""
Begin DoDot:3
+36 IF FLD'=""
DO GETS^DIQ(FILE,DFN_",",FLD,"E","ARRAY")
QUIT
+37 DO GETS^DIQ(SECFILE,DFN_",",SECFLD,"E","ARRAY")
End DoDot:3
+38 SET FL=$ORDER(ARRAY(""))
IF FL=""
QUIT
+39 SET FD=$ORDER(ARRAY(FL,DFN_",",""))
IF FD=""
QUIT
+40 SET AN=0
SET TXT=ARRAY(FL,DFN_",",FD,"E")
IF TXT=""
QUIT
+41 KILL @TXT@("E")
+42 FOR
SET AN=$ORDER(@TXT@(AN))
IF AN=""
QUIT
SET VALUE=VALUE_@TXT@(AN)_$CHAR(10)
End DoDot:2
+43 SET HEADR=HEADR_HDR_"^"
+44 SET HDATA=HDATA_$GET(VALUE)_"^"
SET VALUE=""
End DoDot:1
+45 SET HEADR=$$TKO^AGGUL1(HEADR,"^")
SET HDATA=$$TKO^AGGUL1(HDATA,"^")
+46 IF II=0
SET @DATA@(II)=HEADR_$CHAR(30)
+47 SET II=II+1
SET @DATA@(II)=HDATA_$CHAR(30)
+48 ;
+49 QUIT
+50 ;
DOTH(AGPATDFN) ;EP - Return the list of Other Languages Spoken
+1 ;
+2 NEW OTHL,LIEN,LDT,LNG,VAR
+3 ;
+4 ;Missing patient DFN
IF AGPATDFN=""
QUIT ""
+5 ;
+6 SET OTHL=""
+7 ;
+8 ;Pull existing entry IEN
+9 SET LIEN=""
SET LDT=$ORDER(^AUPNPAT(AGPATDFN,86,"B",""),-1)
+10 IF LDT]""
SET LIEN=$ORDER(^AUPNPAT(AGPATDFN,86,"B",LDT,""),-1)
+11 ;
+12 ;No Language Information on File
IF LIEN=""
QUIT ""
+13 ;
+14 ;Pull Other Languages
+15 DO GETS^DIQ(9000001.86,LIEN_","_AGPATDFN_",",".05*","E","VAR")
+16 ;
+17 SET IEN=""
FOR
SET IEN=$ORDER(VAR(9000001.8605,IEN))
IF IEN=""
QUIT
SET LNG=$GET(VAR(9000001.8605,IEN,".01","E"))
IF LNG]""
SET OTHL=OTHL_$SELECT(OTHL="":"",1:", ")_LNG
IF OTHL[", "
SET OTHL="MORE THAN ONE LANGUAGE"
QUIT
+18 QUIT OTHL
+19 ;
DINTW(AGPATDFN) ;EP - Return the list of Internet WHERE values
+1 ;
+2 NEW INTW,LIEN,LDT,WHERE,VAR,IEN
+3 ;
+4 ;Missing patient DFN
IF AGPATDFN=""
QUIT ""
+5 ;
+6 SET INTW=""
+7 ;
+8 ;Pull existing entry IEN
+9 SET LIEN=""
SET LDT=$ORDER(^AUPNPAT(AGPATDFN,81,"B",""),-1)
+10 IF LDT]""
SET LIEN=$ORDER(^AUPNPAT(AGPATDFN,81,"B",LDT,""),-1)
+11 ;
+12 ;No Internet Information on File
IF LIEN=""
QUIT ""
+13 ;
+14 ;Pull Internet WHERE values
+15 DO GETS^DIQ(9000001.81,LIEN_","_AGPATDFN_",",".04*","I","VAR")
+16 ;
+17 SET IEN=""
FOR
SET IEN=$ORDER(VAR(9000001.811,IEN))
IF IEN=""
QUIT
SET WHERE=$GET(VAR(9000001.811,IEN,".01","I"))
IF WHERE]""
SET INTW=INTW_$SELECT(INTW="":"",1:", ")_WHERE
+18 QUIT INTW
+19 ;
ERR ;
+1 DO ^%ZTER
+2 NEW Y,ERRDTM
+3 SET Y=$$NOW^XLFDT()
XECUTE ^DD("DD")
SET ERRDTM=Y
+4 SET BMXSEC="Recording that an error occurred at "_ERRDTM
+5 IF $DATA(II)
IF $DATA(DATA)
SET II=II+1
SET @DATA@(II)=$CHAR(31)
+6 QUIT
