SDECPTCX ;ALB/SAT,LAB - VISTA SCHEDULING RPCS ;JUL 25,2022
;;5.3;Scheduling;**627,658,823**;Aug 13, 1993;Build 9
;;Per VHA Directive 6402, this routine should not be modified
;
Q
;
;=================================================================
; Selects patient & returns key information
; 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19
; NAME^SEX^DOB^SSN^LOCIEN^LOCNM^RMBD^VET^SENSITIVE^ADMITTED^HRN^SC^SC%^ICN^DOD^TS^PRIMTEAM^PRIMPRV^ATTND
PTINFO(DATA,DFN,SLCT) ;
N X,CA,WL,RB,TS,DOD,AT,VT,VAEL,VAERR,VDT,LINE
K ^TMP("ORWPCE",$J)
Q:'$D(^DPT(+DFN,0))
S X=^DPT(DFN,0),WL=$P($G(^(.1)),U),RB=$P($G(^(.101)),U),CA=+$G(^(.105)),TS=+$G(^(.103)),DOD=+$G(^(.35)),AT=+$G(^(.1041)),VT=$G(^("VET"))
;S DATA=$P(X,U,1,3)_U_$$FMTSSN($P(X,U,9))_U_U_WL_U_RB
S DATA=$P(X,U,1,3)_U_$$LAST4SSN^SDESINPUTVALUTL(DFN)_U_U_WL_U_RB
S:$L(WL) $P(DATA,U,5)=+$G(^DIC(42,+$O(^DIC(42,"B",WL,0)),44))
S $P(DATA,U,8)=VT="Y"
S $P(DATA,U,9)=$$ISSENS(DFN)
S:CA $P(DATA,U,10)=$P($G(^DGPM(CA,0)),U)
S:'$D(IOST) IOST="P-OTHER"
S $P(DATA,U,11)=$$HRN(DFN)
D ELIG^VADPT
S $P(DATA,U,12,13)=$P($G(VAEL(3)),U,1,2)
S $P(DATA,U,14)=$$ICN(DFN)
S $P(DATA,U,15)=DOD
S $P(DATA,U,16)=TS
S $P(DATA,U,17)=$P($$OUTPTTM^SDECPTPC(DFN),U,2)
S $P(DATA,U,18)=$P($$OUTPTPR^SDECPTPC(DFN),U,2)
S $P(DATA,U,19)=$S(AT:$P($G(^VA(200,AT,0)),U),1:"")
;D:$G(SLCT) LAST(,DFN)
Q
; Save/retrieve last patient selected for current institution
LAST(DATA,DFN) ;
S DATA=""
Q
;D:$$ISACTIVE($G(DFN)) EN^XPAR("USR","BEHOPTCX LAST PATIENT","`"_DUZ(2),"`"_DFN)
;S DATA=$$GET^XPAR("USR","BEHOPTCX LAST PATIENT",DUZ(2),"I")
;S:DATA ^DISV(DUZ,"^DPT(")=DATA
;S:'$$GET^XPAR("ALL","BEHOPTCX RECALL LAST") DATA=""
Q
; Returns true if selectable patient
ISACTIVE(DFN,QUALS) ;EP
N X
;S:'$D(DEMO) DEMO=+$$GET^XPAR("ALL","BEHOPTCX DEMO MODE",,"Q")
S X=$G(^DPT(+DFN,0))
Q:'$L(X)!$P(X,U,19) 0
;I '$P(X,U,21),$$LKPQUAL("@BEHOPTCX DEMO MODE",.QUALS) Q 0
;Q:$$LKPQUAL("MSC DG ALL SITES HIPAA",.QUALS) 1
;Q:'$O(^AUPNPAT(DFN,41,0)) '$$LKPQUAL("@BEHOPTCX REQUIRES HRN",.QUALS)
Q ''$L($$HRN(DFN))
; Return requested lookup qualifier (NOT USED)
LKPQUAL(QUAL,CACHE) ;EP
N RET
S RET=$G(CACHE(QUAL))
S:'$L(RET) (RET,CACHE(QUAL))=+$$APSEC^SDEC01(QUAL,DUZ)
Q RET
; Returns sensitive patient status
ISSENS(DFN) ;
N RET
;D PTSEC^DGSEC4(.RET,DFN,0) ;alb/sat 658
D PTSEC4^SDECUTL(.RET,DFN,0)
Q $G(RET(1))
; Return ICN
ICN(DFN) N X
S X=$S($L($T(GETICN^MPIF001)):+$$GETICN^MPIF001(DFN),1:"")
Q $S(X>0:X,1:"")
; Return HRN given DFN
HRN(DFN) ;EP
N X
S X=$G(^AUPNPAT(DFN,41,+$G(DUZ(2)),0))
Q $S($P(X,U,3):"",1:$P(X,U,2))
;
FMTSSN(SSN,MF) ;EP - P7 ;msc/sat add MF flag to mask SSN 0=no mask; 1=mask
N X
S MF=$G(MF,0)
S X=$S(MF:$E(SSN,6,$L(SSN)),1:SSN)
Q:MF "XXX-XX-"_$S($L(X):X,1:"XXXX")
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDECPTCX 2892 printed Apr 09, 2024@22:02:42 Page 2
SDECPTCX ;ALB/SAT,LAB - VISTA SCHEDULING RPCS ;JUL 25,2022
+1 ;;5.3;Scheduling;**627,658,823**;Aug 13, 1993;Build 9
+2 ;;Per VHA Directive 6402, this routine should not be modified
+3 ;
+4 QUIT
+5 ;
+6 ;=================================================================
+7 ; Selects patient & returns key information
+8 ; 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19
+9 ; NAME^SEX^DOB^SSN^LOCIEN^LOCNM^RMBD^VET^SENSITIVE^ADMITTED^HRN^SC^SC%^ICN^DOD^TS^PRIMTEAM^PRIMPRV^ATTND
PTINFO(DATA,DFN,SLCT) ;
+1 NEW X,CA,WL,RB,TS,DOD,AT,VT,VAEL,VAERR,VDT,LINE
+2 KILL ^TMP("ORWPCE",$JOB)
+3 if '$DATA(^DPT(+DFN,0))
QUIT
+4 SET X=^DPT(DFN,0)
SET WL=$PIECE($GET(^(.1)),U)
SET RB=$PIECE($GET(^(.101)),U)
SET CA=+$GET(^(.105))
SET TS=+$GET(^(.103))
SET DOD=+$GET(^(.35))
SET AT=+$GET(^(.1041))
SET VT=$GET(^("VET"))
+5 ;S DATA=$P(X,U,1,3)_U_$$FMTSSN($P(X,U,9))_U_U_WL_U_RB
+6 SET DATA=$PIECE(X,U,1,3)_U_$$LAST4SSN^SDESINPUTVALUTL(DFN)_U_U_WL_U_RB
+7 if $LENGTH(WL)
SET $PIECE(DATA,U,5)=+$GET(^DIC(42,+$ORDER(^DIC(42,"B",WL,0)),44))
+8 SET $PIECE(DATA,U,8)=VT="Y"
+9 SET $PIECE(DATA,U,9)=$$ISSENS(DFN)
+10 if CA
SET $PIECE(DATA,U,10)=$PIECE($GET(^DGPM(CA,0)),U)
+11 if '$DATA(IOST)
SET IOST="P-OTHER"
+12 SET $PIECE(DATA,U,11)=$$HRN(DFN)
+13 DO ELIG^VADPT
+14 SET $PIECE(DATA,U,12,13)=$PIECE($GET(VAEL(3)),U,1,2)
+15 SET $PIECE(DATA,U,14)=$$ICN(DFN)
+16 SET $PIECE(DATA,U,15)=DOD
+17 SET $PIECE(DATA,U,16)=TS
+18 SET $PIECE(DATA,U,17)=$PIECE($$OUTPTTM^SDECPTPC(DFN),U,2)
+19 SET $PIECE(DATA,U,18)=$PIECE($$OUTPTPR^SDECPTPC(DFN),U,2)
+20 SET $PIECE(DATA,U,19)=$SELECT(AT:$PIECE($GET(^VA(200,AT,0)),U),1:"")
+21 ;D:$G(SLCT) LAST(,DFN)
+22 QUIT
+23 ; Save/retrieve last patient selected for current institution
LAST(DATA,DFN) ;
+1 SET DATA=""
+2 QUIT
+3 ;D:$$ISACTIVE($G(DFN)) EN^XPAR("USR","BEHOPTCX LAST PATIENT","`"_DUZ(2),"`"_DFN)
+4 ;S DATA=$$GET^XPAR("USR","BEHOPTCX LAST PATIENT",DUZ(2),"I")
+5 ;S:DATA ^DISV(DUZ,"^DPT(")=DATA
+6 ;S:'$$GET^XPAR("ALL","BEHOPTCX RECALL LAST") DATA=""
+7 QUIT
+8 ; Returns true if selectable patient
ISACTIVE(DFN,QUALS) ;EP
+1 NEW X
+2 ;S:'$D(DEMO) DEMO=+$$GET^XPAR("ALL","BEHOPTCX DEMO MODE",,"Q")
+3 SET X=$GET(^DPT(+DFN,0))
+4 if '$LENGTH(X)!$PIECE(X,U,19)
QUIT 0
+5 ;I '$P(X,U,21),$$LKPQUAL("@BEHOPTCX DEMO MODE",.QUALS) Q 0
+6 ;Q:$$LKPQUAL("MSC DG ALL SITES HIPAA",.QUALS) 1
+7 ;Q:'$O(^AUPNPAT(DFN,41,0)) '$$LKPQUAL("@BEHOPTCX REQUIRES HRN",.QUALS)
+8 QUIT ''$LENGTH($$HRN(DFN))
+9 ; Return requested lookup qualifier (NOT USED)
LKPQUAL(QUAL,CACHE) ;EP
+1 NEW RET
+2 SET RET=$GET(CACHE(QUAL))
+3 if '$LENGTH(RET)
SET (RET,CACHE(QUAL))=+$$APSEC^SDEC01(QUAL,DUZ)
+4 QUIT RET
+5 ; Returns sensitive patient status
ISSENS(DFN) ;
+1 NEW RET
+2 ;D PTSEC^DGSEC4(.RET,DFN,0) ;alb/sat 658
+3 DO PTSEC4^SDECUTL(.RET,DFN,0)
+4 QUIT $GET(RET(1))
+5 ; Return ICN
ICN(DFN) NEW X
+1 SET X=$SELECT($LENGTH($TEXT(GETICN^MPIF001)):+$$GETICN^MPIF001(DFN),1:"")
+2 QUIT $SELECT(X>0:X,1:"")
+3 ; Return HRN given DFN
HRN(DFN) ;EP
+1 NEW X
+2 SET X=$GET(^AUPNPAT(DFN,41,+$GET(DUZ(2)),0))
+3 QUIT $SELECT($PIECE(X,U,3):"",1:$PIECE(X,U,2))
+4 ;
FMTSSN(SSN,MF) ;EP - P7 ;msc/sat add MF flag to mask SSN 0=no mask; 1=mask
+1 NEW X
+2 SET MF=$GET(MF,0)
+3 SET X=$SELECT(MF:$EXTRACT(SSN,6,$LENGTH(SSN)),1:SSN)
+4 if MF
QUIT "XXX-XX-"_$SELECT($LENGTH(X):X,1:"XXXX")
+5 QUIT X
