DGQPT ; SLC/MKB - Patient Selection ;8/8/97 13:07
;;5.3;Registration;**447,796**;Aug 13, 1993;Build 6
;
; SLC/PKS - 3/2000: Modified to deal with "Combinations."
;
EN ; -- main entry point for DG PATIENT SELECTION
I $G(DGVP),'($D(DGPNM)&$D(DGSSN)) K DGVP ; reset
D EN^VALM("DG PATIENT SELECTION")
Q
;
HDR ; -- header code
N X I '$G(DGVP) S X="** No patient selected **"
E S X=$G(DGPNM)_" "_$G(DGSSN)
S VALMHDR(1)="Current patient: "_X
Q
;
INIT ; -- init variables and list array
; Modifications for multiple "Combination" lists by PKS.
;
; PARAM herein might end up as: DGLP DEFAULT CLINIC WEDNESDAY
; (Param Name and current DOW)
; DGY might end up passed as: 5^5^C;1;T-360;T+60;A
; (#lines^#pts^source;serviceSection;startDate;stopDate;sort)
;
N DGY,DGX,PARAM,DGYZB,DGYZE
;
;added by CLA 12/12/96 - gets SERVICE/SECTION of user:
N DGSRV S DGSRV=$G(^VA(200,DUZ,5)) I +DGSRV>0 S DGSRV=$P(DGSRV,U)
;
S DGY=$$GET^XPAR("USR^SRV.`"_$G(DGSRV),"DGLP DEFAULT LIST SOURCE",1,"I") ; Gets default list source for this user.
I $L(DGY) D S DGY=DGY_";"_DGX
. ; PKS: Set "PARAM" var to parameter name in param def file:
. S PARAM="DGLP DEFAULT "_$S(DGY="T":"TEAM",DGY="S":"SPECIALTY",DGY="P":"PROVIDER",DGY="W":"WARD",DGY="C":"CLINIC",DGY="M":"COMBINATION",1:"")
. S:DGY="C" PARAM=PARAM_" "_$$UP^XLFSTR($$DOW^XLFDT(DT)) ; For clinics, add current DOW.
. S DGX=$$GET^XPAR("USR^SRV.`"_$G(DGSRV),PARAM,1,"I") ; Source param.
. ; Next lines modified by PKS for "Combinations" and dates:
. I (DGY="C")!(DGY="M") D
. . S DGYZB=$$UP^XLFSTR($$GET^XPAR("USR^SRV.`"_$G(DGSRV)_"^DIV^SYS^PKG","DGLP DEFAULT CLINIC START DATE",1,"I")) ; Gets clinic start date.
. . I DGYZB="T+0" S DGYZB=$$FMTE^XLFDT(DT,DGYZB)
. . S DGX=DGX_";"_DGYZB
. . S DGYZE=$$UP^XLFSTR($$GET^XPAR("USR^SRV.`"_$G(DGSRV)_"^DIV^SYS^PKG","DGLP DEFAULT CLINIC STOP DATE",1,"I")) ; Add ";" & stop date.
. . I DGYZE="T+0" S DGYZE=$$FMTE^XLFDT(DT,DGYZE)
. . S DGX=DGX_";"_DGYZE
S $P(DGY,";",5)=$$GET^XPAR("USR^SRV.`"_$G(DGSRV)_"^DIV^SYS^PKG","DGLP DEFAULT LIST ORDER",1,"I") ; Add default sort order.
;
; Call tag that builds the actual Patient Selection List:
D BUILD(DGY)
Q
;
DEFAULT() ; -- Returns default action
I '$P($G(^TMP("DG",$J,"PATIENTS",0)),U,2) Q "Change View"
I XQORM("B")="Quit" Q "Close"
Q "Next Screen"
;
MSG() ; -- Lmgr msg bar
Q "Enter the number of the patient chart to be opened"
;
HELP ; -- help code
N X D FULL^VALM1 S VALMBCK="R"
W !!,"Enter the display number of the patient whose chart you wish to open"
W !,"or enter a patient name, SSN, or initial/last 4 combination. To"
W !,"change the list of patients displayed on this screen, enter CV. To"
W !,"have the new list automatically displayed when selecting a new patient,"
W !,"enter SV. Enter FD to search by patient name or identifier."
W !!,"Press <return> to continue ..." R X:DTIME
Q
;
EXIT ; -- exit code
K ^TMP("DG",$J,"PATIENTS"),XQORM("ALT")
Q
;
BUILD(LIST) ; -- build list in ^TMP("DG",$J,"PATIENTS")
N DGI,DGX,DGY,LCNT,NUM,DFN,NAME,TYPE,PTR,BEG,END,SORT,DOB,RBED,%DT,X,Y,TITLE,PTID,SENS
S TYPE=$E(LIST),PTR=+$P(LIST,";",2),SORT=$P(LIST,";",5)
; Next 5 lines added by PKS:
I ((SORT="S")&(TYPE'="M")) S SORT="A" ; Reset invalid sorts.
I TYPE="M" D ; Deal with combinations.
.I ((SORT="P")!(SORT="A")!(SORT="S")) Q ; P,A,S are acceptable.
.S SORT="A" ; Default.
S $P(LIST,";",5)=SORT ; Reset in case of change.
S BEG=$P(LIST,";",3) I $L(BEG) S X=BEG,%DT="X" D ^%DT S BEG=Y
S END=$P(LIST,";",4) I $L(END) S X=END,%DT="X" D ^%DT S END=Y
I TYPE="T" D TEAMPTS^DGQPTQ1(.DGY,PTR) S TITLE="Team "_$P($G(^OR(100.21,+PTR,0)),U)
I TYPE="P" D PROVPTS^DGQPTQ2(.DGY,PTR) S TITLE="Provider "_$P($G(^VA(200,+PTR,0)),U)
I TYPE="S" D SPECPTS^DGQPTQ2(.DGY,PTR) S TITLE="Specialty "_$P($G(^DIC(45.7,+PTR,0)),U)
I TYPE="W" D WARDPTS^DGQPTQ2(.DGY,PTR) S TITLE="Ward "_$P($G(^DIC(42,+PTR,0)),U)
I TYPE="C" D CLINPTS^DGQPTQ2(.DGY,PTR,BEG,END) S TITLE="Clinic "_$P($G(^SC(+PTR,0)),U)
; Next line added by PKS for "Combinations:"
I TYPE="M" N MSG D COMBPTS^DGQPTQ6(1,PTR,BEG,END) S TITLE="Combination List" ; Sets MSG,LCNT,NUM, and writes ^TMP("DG",$J,"PATIENTS").
; Next section added by PKS for "Combinations:"
I TYPE="M" D G BQ ; Check MSG var, then go to BQ tag.
.I MSG'="" D ; Did call to COMBPTS assign an error message?
..S LCNT=1,NUM=0 ; Set defaults.
..S ^TMP("DG",$J,"PATIENTS",1,0)=" "_MSG ; Write error msg.
D CLEAN^VALM10 S (LCNT,NUM)=0 ; All but "M" types reset, go on to B1.
;
B1 S DGI=0 F S DGI=$O(DGY(DGI)) Q:DGI'>0 I DGY(DGI) D ; sort
. S DFN=+DGY(DGI)
. ;sort logic added by CLA 7/23/97:
. S DGX=""
. I SORT="P",(TYPE="C") S DGX=$P($G(DGY(DGI)),U,4) D
.. S $P(DGX,".",2)=$E($P(DGX,".",2)_"000",1,4)
..S DGX=DGX_U_$P(DGY(DGI),U,2)
. I SORT="R",(TYPE'="C") S DGX=$P($G(^DPT(+DGY(DGI),.101)),U)_U_$P(DGY(DGI),U,2)
. I SORT="T" S DGX="" ; Need to add terminal digit sorting.
. ; If no sort specified, default to alphabetic (plus app't if clinic type):
. I DGX="" S DGX=$P(DGY(DGI),U,2)_U_$P($G(DGY(DGI)),U,4)
. S ^TMP("DG",$J,"PATIENTS","B",DGX_DFN)=DGY(DGI) ; DFN ^ Name
I '$D(^TMP("DG",$J,"PATIENTS")) D G BQ
. N MSG
. S MSG="No patients found"
. S LCNT=1,NUM=0
. I $D(DGY(1)) S MSG=$P(DGY(1),"^",2) ; error message from search
. S ^TMP("DG",$J,"PATIENTS",1,0)=" "_MSG
B2 S DGX="" F S DGX=$O(^TMP("DG",$J,"PATIENTS","B",DGX)) Q:DGX="" S DGY=^(DGX) D
. S DFN=+DGY,NAME=$P(DGY,U,2)
. S DOB=$$FMTE^XLFDT($P($G(^DPT(DFN,0)),U,3))
. S:(TYPE'="C") RBED=$P($G(^DPT(DFN,.101)),U)
. I (TYPE="C") S RBED=$S(SORT="P":$$FMTE^XLFDT($P(DGX,U)),1:$$FMTE^XLFDT($P(^TMP("DG",$J,"PATIENTS","B",DGX),U,4)))
. ;Q:RBED="" removed by CLA 7/23/97 to prevent blank lines
. S LCNT=LCNT+1,NUM=NUM+1
. S ^TMP("DG",$J,"PATIENTS","IDX",NUM)=DGY ; DFN ^ NAME
. ; Next lines modified/added by PKS on 1/24/2001:
. ; Check for "sensitive" patients:
. S PTID=""
. S PTID=$$ID(DFN)
. S SENS=$$SSN^DPTLK1(DFN)
. I SENS["*" S PTID=""
. S DOB=$$DOB^DPTLK1(DFN)
. S ^TMP("DG",$J,"PATIENTS",LCNT,0)=$$LJ^XLFSTR(NUM,5)_$$LJ^XLFSTR(NAME,31)_$$LJ^XLFSTR(PTID,10)_$$LJ^XLFSTR(DOB,15)_$G(RBED)
. D CNTRL^VALM10(LCNT,1,5,IOINHI,IOINORM)
BQ S ^TMP("DG",$J,"PATIENTS",0)=LCNT_U_NUM_U_$G(LIST) ; #lines^#pts^context
S ^TMP("DG",$J,"PATIENTS","#")=$O(^ORD(101,"B","ORQPT SELECT PATIENT",0))_"^1:"_NUM
S RBED=$S(TYPE="C":"Appointment Date",TYPE="M":"Source Other",1:"Room-Bed")
D CHGCAP^VALM("ROOM-BED",RBED) K VALMHDR
S VALMCNT=LCNT,VALMBG=1,VALMBCK="R" S:$L($G(TITLE)) VALM("TITLE")=TITLE
Q
;
ID(DFN) ; -- Returns short ID for patient ID
N ID S ID=$P($G(^DPT(DFN,.36)),U,4) ; short ID
I '$L(ID) S ID=$E($P($G(^DPT(DFN,0)),U,9),6,9) ; last 4 of SSN
Q "("_$E(NAME)_ID_")"
;
APPT(DFN,CLINIC,FROM,TO) ; -- Return [next?] clinic appointment
N VASD,VAERR K ^UTILITY("VASD",$J)
S VASD("F")=FROM,VASD("T")=TO,VASD("C",CLINIC)=""
D SDA^VADPT S NEXT=+$O(^UTILITY("VASD",$J,0)),NEXT=$P($G(^(NEXT,"I")),U)
K ^UTILITY("VASD",$J)
Q NEXT
;
ALT ; -- XQORM("ALT") code to search File 2 for patient X
N DIC,DFN,Y,DGX S DGX=X D FULL^VALM1
S DIC=2,DIC(0)="EQM",X=$S($D(XQORMRCL):" ",1:DGX)
D ^DIC I Y'>0 S VALMBCK="R" Q ;S XQORMERR=1 Q
S DGX=+$G(^DPT(+Y,.35)) I DGX,'$$OK(DGX) S VALMBCK="R" Q
S DFN=+Y G:DFN'=+$G(DGVP) SLCT1 ; set patient variables
Q
;
FIND ; -- find patient in ^DPT
N X,Y,DIC,DGX,DFN
S DIC=2,DIC(0)="AEQM" D FULL^VALM1
D ^DIC I Y'>0 S VALMBCK="R" Q
S DGX=+$G(^DPT(+Y,.35)) I DGX,'$$OK(DGX) S VALMBCK="R" Q
S DFN=+Y G:DFN'=+$G(DGVP) SLCT1 ; set patient variables
Q
;
SELECT ; -- select patient from list
N NMBR,X,Y,Z,DIC,DFN,DGX S NMBR=+$P(XQORNOD(0),"=",2)
S Y=$G(^TMP("DG",$J,"PATIENTS","IDX",NMBR)),DFN=+Y
I 'DFN W $C(7),!!,NMBR_" is not a valid selection.",! S VALMBCK="" H 1 Q
;W " "_$P(Y,U,2) S ^DISV(DUZ,"^DPT(")=DFN
D FULL^VALM1 S DIC=2,DIC(0)="EQM",X="`"_DFN D ^DIC I Y<0 S VALMBCK="R" Q
S DGX=+$G(^DPT(+Y,.35)) I DGX,'$$OK(DGX) S VALMBCK="R" Q
SLCT1 ; -- may enter here with DFN from FIND
N VADM,VAEL,VAIN,VA,VAERR,LOC,ORCNV
D OERR^VADPT,ELIG^VADPT
S LOC=+$G(^DIC(42,+VAIN(4),44))_";SC(" I 'LOC,'$D(XQAID) D
. I $G(NMBR) N X S X=$$CONTEXT^DGQPT1 I $E(X)="C" S LOC=$P(X,";",2)_";SC(" Q:LOC ; use clinic if selected from list, else ask
. S LOC=""
S DGL=LOC,DGL(0)=$P($G(^SC(+DGL,0)),U),DGL(1)=VAIN(5)
S DGVP=DFN_";DPT(",DGPNM=VADM(1),DGSSN=$P(VADM(2),U,2)
S DGDOB=$P(VADM(3),U,2),DGAGE=VADM(4),DGSEX=$P(VADM(5),U)
S DGTS=+VAIN(3),DGWARD=VAIN(4),DGATTEND=+VAIN(11),DGSC=$G(VAEL(3))
I $P($G(^DGSL(38.1,+DGVP,0)),"^",2),($G(^DPT(+DGVP,.1))]""!$D(^XUSEC("DG SENSITIVITY",DUZ))) D
. ; if senstive patient and (patient inpatient or user holds key)
. ; prevents sensitive patient warning from scrolling off screen
. N X
. W !!,"Press <return> to continue ..."
. R X:DTIME
SLCT2 ; -- convert patient's orders, if not already done
;ORDERS NO LONGER BEING CONVERTED
;S DGCNV=$$OTF^OR3CONV(+DGVP) Q:'DGCNV I DGCNV>0 W !,"DONE" H 1 Q
;I DGCNV<0 W $C(7),!!,$P(DGCNV,U,2) H 2 S VALMBCK="R" Q
Q
;
OK(DATE) ; -- Patient is deceased; ok to continue?
N X,Y,DIR S DIR(0)="YA",DIR("B")="NO"
S DIR("A")="Do you wish to continue? "
W $C(7),!!,"This patient died "_$$FMTE^XLFDT(DATE)_"!"
D ^DIR
Q +Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGQPT 9466 printed Apr 09, 2024@21:56:02 Page 2
DGQPT ; SLC/MKB - Patient Selection ;8/8/97 13:07
+1 ;;5.3;Registration;**447,796**;Aug 13, 1993;Build 6
+2 ;
+3 ; SLC/PKS - 3/2000: Modified to deal with "Combinations."
+4 ;
EN ; -- main entry point for DG PATIENT SELECTION
+1 ; reset
IF $GET(DGVP)
IF '($DATA(DGPNM)&$DATA(DGSSN))
KILL DGVP
+2 DO EN^VALM("DG PATIENT SELECTION")
+3 QUIT
+4 ;
HDR ; -- header code
+1 NEW X
IF '$GET(DGVP)
SET X="** No patient selected **"
+2 IF '$TEST
SET X=$GET(DGPNM)_" "_$GET(DGSSN)
+3 SET VALMHDR(1)="Current patient: "_X
+4 QUIT
+5 ;
INIT ; -- init variables and list array
+1 ; Modifications for multiple "Combination" lists by PKS.
+2 ;
+3 ; PARAM herein might end up as: DGLP DEFAULT CLINIC WEDNESDAY
+4 ; (Param Name and current DOW)
+5 ; DGY might end up passed as: 5^5^C;1;T-360;T+60;A
+6 ; (#lines^#pts^source;serviceSection;startDate;stopDate;sort)
+7 ;
+8 NEW DGY,DGX,PARAM,DGYZB,DGYZE
+9 ;
+10 ;added by CLA 12/12/96 - gets SERVICE/SECTION of user:
+11 NEW DGSRV
SET DGSRV=$GET(^VA(200,DUZ,5))
IF +DGSRV>0
SET DGSRV=$PIECE(DGSRV,U)
+12 ;
+13 ; Gets default list source for this user.
SET DGY=$$GET^XPAR("USR^SRV.`"_$GET(DGSRV),"DGLP DEFAULT LIST SOURCE",1,"I")
+14 IF $LENGTH(DGY)
Begin DoDot:1
+15 ; PKS: Set "PARAM" var to parameter name in param def file:
+16 SET PARAM="DGLP DEFAULT "_$SELECT(DGY="T":"TEAM",DGY="S":"SPECIALTY",DGY="P":"PROVIDER",DGY="W":"WARD",DGY="C":"CLINIC",DGY="M":"COMBINATION",1:"")
+17 ; For clinics, add current DOW.
if DGY="C"
SET PARAM=PARAM_" "_$$UP^XLFSTR($$DOW^XLFDT(DT))
+18 ; Source param.
SET DGX=$$GET^XPAR("USR^SRV.`"_$GET(DGSRV),PARAM,1,"I")
+19 ; Next lines modified by PKS for "Combinations" and dates:
+20 IF (DGY="C")!(DGY="M")
Begin DoDot:2
+21 ; Gets clinic start date.
SET DGYZB=$$UP^XLFSTR($$GET^XPAR("USR^SRV.`"_$GET(DGSRV)_"^DIV^SYS^PKG","DGLP DEFAULT CLINIC START DATE",1,"I"))
+22 IF DGYZB="T+0"
SET DGYZB=$$FMTE^XLFDT(DT,DGYZB)
+23 SET DGX=DGX_";"_DGYZB
+24 ; Add ";" & stop date.
SET DGYZE=$$UP^XLFSTR($$GET^XPAR("USR^SRV.`"_$GET(DGSRV)_"^DIV^SYS^PKG","DGLP DEFAULT CLINIC STOP DATE",1,"I"))
+25 IF DGYZE="T+0"
SET DGYZE=$$FMTE^XLFDT(DT,DGYZE)
+26 SET DGX=DGX_";"_DGYZE
End DoDot:2
End DoDot:1
SET DGY=DGY_";"_DGX
+27 ; Add default sort order.
SET $PIECE(DGY,";",5)=$$GET^XPAR("USR^SRV.`"_$GET(DGSRV)_"^DIV^SYS^PKG","DGLP DEFAULT LIST ORDER",1,"I")
+28 ;
+29 ; Call tag that builds the actual Patient Selection List:
+30 DO BUILD(DGY)
+31 QUIT
+32 ;
DEFAULT() ; -- Returns default action
+1 IF '$PIECE($GET(^TMP("DG",$JOB,"PATIENTS",0)),U,2)
QUIT "Change View"
+2 IF XQORM("B")="Quit"
QUIT "Close"
+3 QUIT "Next Screen"
+4 ;
MSG() ; -- Lmgr msg bar
+1 QUIT "Enter the number of the patient chart to be opened"
+2 ;
HELP ; -- help code
+1 NEW X
DO FULL^VALM1
SET VALMBCK="R"
+2 WRITE !!,"Enter the display number of the patient whose chart you wish to open"
+3 WRITE !,"or enter a patient name, SSN, or initial/last 4 combination. To"
+4 WRITE !,"change the list of patients displayed on this screen, enter CV. To"
+5 WRITE !,"have the new list automatically displayed when selecting a new patient,"
+6 WRITE !,"enter SV. Enter FD to search by patient name or identifier."
+7 WRITE !!,"Press <return> to continue ..."
READ X:DTIME
+8 QUIT
+9 ;
EXIT ; -- exit code
+1 KILL ^TMP("DG",$JOB,"PATIENTS"),XQORM("ALT")
+2 QUIT
+3 ;
BUILD(LIST) ; -- build list in ^TMP("DG",$J,"PATIENTS")
+1 NEW DGI,DGX,DGY,LCNT,NUM,DFN,NAME,TYPE,PTR,BEG,END,SORT,DOB,RBED,%DT,X,Y,TITLE,PTID,SENS
+2 SET TYPE=$EXTRACT(LIST)
SET PTR=+$PIECE(LIST,";",2)
SET SORT=$PIECE(LIST,";",5)
+3 ; Next 5 lines added by PKS:
+4 ; Reset invalid sorts.
IF ((SORT="S")&(TYPE'="M"))
SET SORT="A"
+5 ; Deal with combinations.
IF TYPE="M"
Begin DoDot:1
+6 ; P,A,S are acceptable.
IF ((SORT="P")!(SORT="A")!(SORT="S"))
QUIT
+7 ; Default.
SET SORT="A"
End DoDot:1
+8 ; Reset in case of change.
SET $PIECE(LIST,";",5)=SORT
+9 SET BEG=$PIECE(LIST,";",3)
IF $LENGTH(BEG)
SET X=BEG
SET %DT="X"
DO ^%DT
SET BEG=Y
+10 SET END=$PIECE(LIST,";",4)
IF $LENGTH(END)
SET X=END
SET %DT="X"
DO ^%DT
SET END=Y
+11 IF TYPE="T"
DO TEAMPTS^DGQPTQ1(.DGY,PTR)
SET TITLE="Team "_$PIECE($GET(^OR(100.21,+PTR,0)),U)
+12 IF TYPE="P"
DO PROVPTS^DGQPTQ2(.DGY,PTR)
SET TITLE="Provider "_$PIECE($GET(^VA(200,+PTR,0)),U)
+13 IF TYPE="S"
DO SPECPTS^DGQPTQ2(.DGY,PTR)
SET TITLE="Specialty "_$PIECE($GET(^DIC(45.7,+PTR,0)),U)
+14 IF TYPE="W"
DO WARDPTS^DGQPTQ2(.DGY,PTR)
SET TITLE="Ward "_$PIECE($GET(^DIC(42,+PTR,0)),U)
+15 IF TYPE="C"
DO CLINPTS^DGQPTQ2(.DGY,PTR,BEG,END)
SET TITLE="Clinic "_$PIECE($GET(^SC(+PTR,0)),U)
+16 ; Next line added by PKS for "Combinations:"
+17 ; Sets MSG,LCNT,NUM, and writes ^TMP("DG",$J,"PATIENTS").
IF TYPE="M"
NEW MSG
DO COMBPTS^DGQPTQ6(1,PTR,BEG,END)
SET TITLE="Combination List"
+18 ; Next section added by PKS for "Combinations:"
+19 ; Check MSG var, then go to BQ tag.
IF TYPE="M"
Begin DoDot:1
+20 ; Did call to COMBPTS assign an error message?
IF MSG'=""
Begin DoDot:2
+21 ; Set defaults.
SET LCNT=1
SET NUM=0
+22 ; Write error msg.
SET ^TMP("DG",$JOB,"PATIENTS",1,0)=" "_MSG
End DoDot:2
End DoDot:1
GOTO BQ
+23 ; All but "M" types reset, go on to B1.
DO CLEAN^VALM10
SET (LCNT,NUM)=0
+24 ;
B1 ; sort
SET DGI=0
FOR
SET DGI=$ORDER(DGY(DGI))
if DGI'>0
QUIT
IF DGY(DGI)
Begin DoDot:1
+1 SET DFN=+DGY(DGI)
+2 ;sort logic added by CLA 7/23/97:
+3 SET DGX=""
+4 IF SORT="P"
IF (TYPE="C")
SET DGX=$PIECE($GET(DGY(DGI)),U,4)
Begin DoDot:2
+5 SET $PIECE(DGX,".",2)=$EXTRACT($PIECE(DGX,".",2)_"000",1,4)
+6 SET DGX=DGX_U_$PIECE(DGY(DGI),U,2)
End DoDot:2
+7 IF SORT="R"
IF (TYPE'="C")
SET DGX=$PIECE($GET(^DPT(+DGY(DGI),.101)),U)_U_$PIECE(DGY(DGI),U,2)
+8 ; Need to add terminal digit sorting.
IF SORT="T"
SET DGX=""
+9 ; If no sort specified, default to alphabetic (plus app't if clinic type):
+10 IF DGX=""
SET DGX=$PIECE(DGY(DGI),U,2)_U_$PIECE($GET(DGY(DGI)),U,4)
+11 ; DFN ^ Name
SET ^TMP("DG",$JOB,"PATIENTS","B",DGX_DFN)=DGY(DGI)
End DoDot:1
+12 IF '$DATA(^TMP("DG",$JOB,"PATIENTS"))
Begin DoDot:1
+13 NEW MSG
+14 SET MSG="No patients found"
+15 SET LCNT=1
SET NUM=0
+16 ; error message from search
IF $DATA(DGY(1))
SET MSG=$PIECE(DGY(1),"^",2)
+17 SET ^TMP("DG",$JOB,"PATIENTS",1,0)=" "_MSG
End DoDot:1
GOTO BQ
B2 SET DGX=""
FOR
SET DGX=$ORDER(^TMP("DG",$JOB,"PATIENTS","B",DGX))
if DGX=""
QUIT
SET DGY=^(DGX)
Begin DoDot:1
+1 SET DFN=+DGY
SET NAME=$PIECE(DGY,U,2)
+2 SET DOB=$$FMTE^XLFDT($PIECE($GET(^DPT(DFN,0)),U,3))
+3 if (TYPE'="C")
SET RBED=$PIECE($GET(^DPT(DFN,.101)),U)
+4 IF (TYPE="C")
SET RBED=$SELECT(SORT="P":$$FMTE^XLFDT($PIECE(DGX,U)),1:$$FMTE^XLFDT($PIECE(^TMP("DG",$JOB,"PATIENTS","B",DGX),U,4)))
+5 ;Q:RBED="" removed by CLA 7/23/97 to prevent blank lines
+6 SET LCNT=LCNT+1
SET NUM=NUM+1
+7 ; DFN ^ NAME
SET ^TMP("DG",$JOB,"PATIENTS","IDX",NUM)=DGY
+8 ; Next lines modified/added by PKS on 1/24/2001:
+9 ; Check for "sensitive" patients:
+10 SET PTID=""
+11 SET PTID=$$ID(DFN)
+12 SET SENS=$$SSN^DPTLK1(DFN)
+13 IF SENS["*"
SET PTID=""
+14 SET DOB=$$DOB^DPTLK1(DFN)
+15 SET ^TMP("DG",$JOB,"PATIENTS",LCNT,0)=$$LJ^XLFSTR(NUM,5)_$$LJ^XLFSTR(NAME,31)_$$LJ^XLFSTR(PTID,10)_$$LJ^XLFSTR(DOB,15)_$GET(RBED)
+16 DO CNTRL^VALM10(LCNT,1,5,IOINHI,IOINORM)
End DoDot:1
BQ ; #lines^#pts^context
SET ^TMP("DG",$JOB,"PATIENTS",0)=LCNT_U_NUM_U_$GET(LIST)
+1 SET ^TMP("DG",$JOB,"PATIENTS","#")=$ORDER(^ORD(101,"B","ORQPT SELECT PATIENT",0))_"^1:"_NUM
+2 SET RBED=$SELECT(TYPE="C":"Appointment Date",TYPE="M":"Source Other",1:"Room-Bed")
+3 DO CHGCAP^VALM("ROOM-BED",RBED)
KILL VALMHDR
+4 SET VALMCNT=LCNT
SET VALMBG=1
SET VALMBCK="R"
if $LENGTH($GET(TITLE))
SET VALM("TITLE")=TITLE
+5 QUIT
+6 ;
ID(DFN) ; -- Returns short ID for patient ID
+1 ; short ID
NEW ID
SET ID=$PIECE($GET(^DPT(DFN,.36)),U,4)
+2 ; last 4 of SSN
IF '$LENGTH(ID)
SET ID=$EXTRACT($PIECE($GET(^DPT(DFN,0)),U,9),6,9)
+3 QUIT "("_$EXTRACT(NAME)_ID_")"
+4 ;
APPT(DFN,CLINIC,FROM,TO) ; -- Return [next?] clinic appointment
+1 NEW VASD,VAERR
KILL ^UTILITY("VASD",$JOB)
+2 SET VASD("F")=FROM
SET VASD("T")=TO
SET VASD("C",CLINIC)=""
+3 DO SDA^VADPT
SET NEXT=+$ORDER(^UTILITY("VASD",$JOB,0))
SET NEXT=$PIECE($GET(^(NEXT,"I")),U)
+4 KILL ^UTILITY("VASD",$JOB)
+5 QUIT NEXT
+6 ;
ALT ; -- XQORM("ALT") code to search File 2 for patient X
+1 NEW DIC,DFN,Y,DGX
SET DGX=X
DO FULL^VALM1
+2 SET DIC=2
SET DIC(0)="EQM"
SET X=$SELECT($DATA(XQORMRCL):" ",1:DGX)
+3 ;S XQORMERR=1 Q
DO ^DIC
IF Y'>0
SET VALMBCK="R"
QUIT
+4 SET DGX=+$GET(^DPT(+Y,.35))
IF DGX
IF '$$OK(DGX)
SET VALMBCK="R"
QUIT
+5 ; set patient variables
SET DFN=+Y
if DFN'=+$GET(DGVP)
GOTO SLCT1
+6 QUIT
+7 ;
FIND ; -- find patient in ^DPT
+1 NEW X,Y,DIC,DGX,DFN
+2 SET DIC=2
SET DIC(0)="AEQM"
DO FULL^VALM1
+3 DO ^DIC
IF Y'>0
SET VALMBCK="R"
QUIT
+4 SET DGX=+$GET(^DPT(+Y,.35))
IF DGX
IF '$$OK(DGX)
SET VALMBCK="R"
QUIT
+5 ; set patient variables
SET DFN=+Y
if DFN'=+$GET(DGVP)
GOTO SLCT1
+6 QUIT
+7 ;
SELECT ; -- select patient from list
+1 NEW NMBR,X,Y,Z,DIC,DFN,DGX
SET NMBR=+$PIECE(XQORNOD(0),"=",2)
+2 SET Y=$GET(^TMP("DG",$JOB,"PATIENTS","IDX",NMBR))
SET DFN=+Y
+3 IF 'DFN
WRITE $CHAR(7),!!,NMBR_" is not a valid selection.",!
SET VALMBCK=""
HANG 1
QUIT
+4 ;W " "_$P(Y,U,2) S ^DISV(DUZ,"^DPT(")=DFN
+5 DO FULL^VALM1
SET DIC=2
SET DIC(0)="EQM"
SET X="`"_DFN
DO ^DIC
IF Y<0
SET VALMBCK="R"
QUIT
+6 SET DGX=+$GET(^DPT(+Y,.35))
IF DGX
IF '$$OK(DGX)
SET VALMBCK="R"
QUIT
SLCT1 ; -- may enter here with DFN from FIND
+1 NEW VADM,VAEL,VAIN,VA,VAERR,LOC,ORCNV
+2 DO OERR^VADPT
DO ELIG^VADPT
+3 SET LOC=+$GET(^DIC(42,+VAIN(4),44))_";SC("
IF 'LOC
IF '$DATA(XQAID)
Begin DoDot:1
+4 ; use clinic if selected from list, else ask
IF $GET(NMBR)
NEW X
SET X=$$CONTEXT^DGQPT1
IF $EXTRACT(X)="C"
SET LOC=$PIECE(X,";",2)_";SC("
if LOC
QUIT
+5 SET LOC=""
End DoDot:1
+6 SET DGL=LOC
SET DGL(0)=$PIECE($GET(^SC(+DGL,0)),U)
SET DGL(1)=VAIN(5)
+7 SET DGVP=DFN_";DPT("
SET DGPNM=VADM(1)
SET DGSSN=$PIECE(VADM(2),U,2)
+8 SET DGDOB=$PIECE(VADM(3),U,2)
SET DGAGE=VADM(4)
SET DGSEX=$PIECE(VADM(5),U)
+9 SET DGTS=+VAIN(3)
SET DGWARD=VAIN(4)
SET DGATTEND=+VAIN(11)
SET DGSC=$GET(VAEL(3))
+10 IF $PIECE($GET(^DGSL(38.1,+DGVP,0)),"^",2)
IF ($GET(^DPT(+DGVP,.1))]""!$DATA(^XUSEC("DG SENSITIVITY",DUZ)))
Begin DoDot:1
+11 ; if senstive patient and (patient inpatient or user holds key)
+12 ; prevents sensitive patient warning from scrolling off screen
+13 NEW X
+14 WRITE !!,"Press <return> to continue ..."
+15 READ X:DTIME
End DoDot:1
SLCT2 ; -- convert patient's orders, if not already done
+1 ;ORDERS NO LONGER BEING CONVERTED
+2 ;S DGCNV=$$OTF^OR3CONV(+DGVP) Q:'DGCNV I DGCNV>0 W !,"DONE" H 1 Q
+3 ;I DGCNV<0 W $C(7),!!,$P(DGCNV,U,2) H 2 S VALMBCK="R" Q
+4 QUIT
+5 ;
OK(DATE) ; -- Patient is deceased; ok to continue?
+1 NEW X,Y,DIR
SET DIR(0)="YA"
SET DIR("B")="NO"
+2 SET DIR("A")="Do you wish to continue? "
+3 WRITE $CHAR(7),!!,"This patient died "_$$FMTE^XLFDT(DATE)_"!"
+4 DO ^DIR
+5 QUIT +Y
