SDPPAT1 ;ALB/CAW-Patient Profile (Generic Patient Info) Screen 1;5/4/92
;;5.3;Scheduling;**6,140,441**;Aug 13, 1993;Build 14
;
;
PDATA ; Patient Data
N SD,SDELIG,SDDIS,SDCNT,CNT,SDCT,SDCOPS
F SD=0,.3,.11,.121,.122,.13,.32,.321,.35,.36,.52,"TYPE","VET" S SD(SD)=$G(^DPT(DFN,SD))
I $D(^DPT(DFN,.372,0)) S SDDIS=0 F S SDDIS=$O(^DPT(DFN,.372,SDDIS)) Q:'SDDIS D
.S SDDIS(SDDIS)=$G(^DPT(DFN,.372,SDDIS,0))
.S SDDIS(SDDIS)=$P($G(^DIC(31,+$P(SDDIS(SDDIS),U),0)),U)_" ("_$S($P(SDDIS(SDDIS),U,3):"SC-",1:"NSC-")_$P(SDDIS(SDDIS),U,2)_"%)"
.S SDCNT(SDDIS)=$L($P(SDDIS(SDDIS),U))+2
S SDELIG=0 F S SDELIG=$O(^DPT(DFN,"E",SDELIG)) Q:'SDELIG S:SDELIG'=+SD(.36) SDELIG(SDELIG)=$G(^DPT(DFN,"E",SDELIG,0))
S SD("MT")=$$LST^DGMTU(DFN) I 'SD("MT") S SDCOPS=$$LST^DGMTU(DFN,"",2)
S SDFSTCOL=22,SDSECCOL=60
PTDOB ; Date of Birth and Marital Status Info
;
S X="",X=$$SETSTR^VALM1("Date of Birth:",X,7,14)
S X=$$SETSTR^VALM1($$FTIME^VALM1($P(SD(0),U,3)),X,SDFSTCOL,18)
S X=$$SETSTR^VALM1("Marital Status:",X,44,15)
S X=$$SETSTR^VALM1($P($G(^DIC(11,+$P(SD(0),U,5),0)),U),X,SDSECCOL,20)
D SET(X)
PTSEX ; Sex and Religions Pref. Info
;
S X="",X=$$SETSTR^VALM1("Sex:",X,17,4)
S X=$$SETSTR^VALM1($S($P(SD(0),U,2)="F":"FEMALE",$P(SD(0),U,2)="M":"MALE",1:"UNKNOWN"),X,SDFSTCOL,18)
S X=$$SETSTR^VALM1("Religious Pref.:",X,43,16)
S X=$$SETSTR^VALM1($P($G(^DIC(13,+$P(SD(0),U,8),0)),U),X,SDSECCOL,20)
D SET(X)
PTRACE ; SSN and Occupation Info
;
S X="",X=$$SETSTR^VALM1("Patient ID:",X,10,11)
S X=$$SETSTR^VALM1(VA("PID"),X,SDFSTCOL,20)
S X=$$SETSTR^VALM1("Occupation:",X,48,11)
S X=$$SETSTR^VALM1($P(SD(0),U,7),X,SDSECCOL,20)
D SET(X)
PWHO ; Who entered and Place of Birth
;
S X="",X=$$SETSTR^VALM1("Who entered:",X,9,12)
S X=$$SETSTR^VALM1($P($G(^VA(200,+$P(SD(0),U,15),0)),U),X,SDFSTCOL,20)
S X=$$SETSTR^VALM1("Place of Birth:",X,44,15)
S X=$$SETSTR^VALM1(($P(SD(0),U,11)_$S($P(SD(0),U,12):", ",1:"")_$P($G(^DIC(5,+$P(SD(0),U,12),0)),U)),X,SDSECCOL,20)
D SET(X)
PWHEN ; Date entered
S X="",X=$$SETSTR^VALM1("Date entered:",X,8,13)
S X=$$SETSTR^VALM1($S($P(SD(0),U,16):$TR($$FMTE^XLFDT($P(SD(0),U,16),"5DF")," ","0"),1:""),X,SDFSTCOL,20)
D SET(X)
MT ; Current Means Test - if applicable
;
S X="" I SD("MT")'="" D
.S X=$$SETSTR^VALM1("Current Means Test:",X,2,19)
.S X=$$SETSTR^VALM1($P(SD("MT"),U,3),X,SDFSTCOL,30)
.S X=$$SETSTR^VALM1("Date Means Test:",X,43,16)
.S X=$$SETSTR^VALM1($TR($$FMTE^XLFDT($P(SD("MT"),U,2),"5DF")," ","0"),X,SDSECCOL,20)
I $D(SDCOPS),+SDCOPS D
.S X=$$SETSTR^VALM1("Current Co-Pay Test:",X,1,20)
.S X=$$SETSTR^VALM1($P(SDCOPS,U,3),X,SDFSTCOL,30)
.S X=$$SETSTR^VALM1("Date Co-Pay Test:",X,42,17)
.S X=$$SETSTR^VALM1($TR($$FMTE^XLFDT($P(SDCOPS,U,2),"5DF")," ","0"),X,SDSECCOL,20)
D SET(X)
S X="" I $P(SD(0),U,10)'="" D
.S X=$$SETSTR^VALM1("Remarks:",X,13,8)
.S X=$$SETSTR^VALM1($P(SD(0),U,10),X,SDFSTCOL,60)
D SET(X)
PRIME ; Primary Eligibility
;
S X="",X=$$SETSTR^VALM1("Primary Eligibility:",X,1,20)
S X=$$SETSTR^VALM1($$FELIG(SD(.36)),X,SDFSTCOL,30)
D SET(X)
OTHERE ; Other Eligibilities and Date of Death
;
S X="",X=$$SETSTR^VALM1("Other Eligibilities:",X,1,20)
I $P(SD(.35),U)'="" S X=$$SETSTR^VALM1("Date of Death:",X,45,14),X=$$SETSTR^VALM1($TR($$FMTE^XLFDT($P(SD(.35),U),"5DF")," ","0"),X,SDSECCOL,20)
D SET(X)
VET ; List of other eligibilities and VETERAN(Y/N)
S SDELIG=0 F S SDELIG=$O(SDELIG(SDELIG)) Q:'SDELIG S SDCT=$G(SDCT)+1,ROU=$S(SDCT=1:"OTH1",SDCT=2:"OTH2",1:"OTHM") D @ROU I SDCT=5 S X="",X=$$SETSTR^VALM1("(this patient has more 'other eligibilities that are not listed)",X,10,65) D SET(X) Q
I '$D(SDCT) D
.S X="",X=$$SETSTR^VALM1("VETERAN(Y/N):",X,46,13)
.S X=$$SETSTR^VALM1($S(SD("VET")="N":"NO",SD("VET")="Y":"YES",1:"UNKNOWN"),X,SDSECCOL,7)
.D SET(X)
.S X="",X=$$SETSTR^VALM1("Type:",X,54,5)
.S X=$$SETSTR^VALM1($P($G(^DG(391,+SD("TYPE"),0)),U),X,SDSECCOL,20)
.D SET(X)
F SD=SDLN:1:12 D SET("")
D ^SDPPAT2
S VALMCNT=SDLN
Q
SET(X) ; Set in ^TMP global for display
;
S SDLN=$G(SDLN)+1,^TMP("SDPP",$J,SDLN,0)=X
Q
OTH1 ; First 'Other' Eligibility' and VETERAN(Y/N)
S X="",X=$$SETSTR^VALM1($$FELIG(SDELIG(SDELIG)),X,10,30)
S X=$$SETSTR^VALM1("VETERAN(Y/N):",X,46,13)
S X=$$SETSTR^VALM1($S(SD("VET")="N":"NO",SD("VET")="Y":"YES",1:"UNKNOWN"),X,SDSECCOL,7)
D SET(X)
Q
OTH2 ; Second 'Other Eligbility' and TYPE
S X="",X=$$SETSTR^VALM1($$FELIG(SDELIG(SDELIG)),X,10,30)
S X=$$SETSTR^VALM1("Type:",X,53,5)
S X=$$SETSTR^VALM1($P($G(^DG(391,+SD("TYPE"),0)),U),X,SDSECCOL,20)
D SET(X)
Q
OTHM ; Rest of 'Other Eligibilities'
Q:SDCT>4
S X="",X=$$SETSTR^VALM1($$FELIG(SDELIG(SDELIG)),X,10,30)
D SET(X)
Q
FELIG(ELIG) ;
; input - pointer to eligibility file
; output - name of eligibility
Q $P($G(^DIC(8,+ELIG,0)),U)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDPPAT1 4841 printed Dec 13, 2024@02:59:42 Page 2
SDPPAT1 ;ALB/CAW-Patient Profile (Generic Patient Info) Screen 1;5/4/92
+1 ;;5.3;Scheduling;**6,140,441**;Aug 13, 1993;Build 14
+2 ;
+3 ;
PDATA ; Patient Data
+1 NEW SD,SDELIG,SDDIS,SDCNT,CNT,SDCT,SDCOPS
+2 FOR SD=0,.3,.11,.121,.122,.13,.32,.321,.35,.36,.52,"TYPE","VET"
SET SD(SD)=$GET(^DPT(DFN,SD))
+3 IF $DATA(^DPT(DFN,.372,0))
SET SDDIS=0
FOR
SET SDDIS=$ORDER(^DPT(DFN,.372,SDDIS))
if 'SDDIS
QUIT
Begin DoDot:1
+4 SET SDDIS(SDDIS)=$GET(^DPT(DFN,.372,SDDIS,0))
+5 SET SDDIS(SDDIS)=$PIECE($GET(^DIC(31,+$PIECE(SDDIS(SDDIS),U),0)),U)_" ("_$SELECT($PIECE(SDDIS(SDDIS),U,3):"SC-",1:"NSC-")_$PIECE(SDDIS(SDDIS),U,2)_"%)"
+6 SET SDCNT(SDDIS)=$LENGTH($PIECE(SDDIS(SDDIS),U))+2
End DoDot:1
+7 SET SDELIG=0
FOR
SET SDELIG=$ORDER(^DPT(DFN,"E",SDELIG))
if 'SDELIG
QUIT
if SDELIG'=+SD(.36)
SET SDELIG(SDELIG)=$GET(^DPT(DFN,"E",SDELIG,0))
+8 SET SD("MT")=$$LST^DGMTU(DFN)
IF 'SD("MT")
SET SDCOPS=$$LST^DGMTU(DFN,"",2)
+9 SET SDFSTCOL=22
SET SDSECCOL=60
PTDOB ; Date of Birth and Marital Status Info
+1 ;
+2 SET X=""
SET X=$$SETSTR^VALM1("Date of Birth:",X,7,14)
+3 SET X=$$SETSTR^VALM1($$FTIME^VALM1($PIECE(SD(0),U,3)),X,SDFSTCOL,18)
+4 SET X=$$SETSTR^VALM1("Marital Status:",X,44,15)
+5 SET X=$$SETSTR^VALM1($PIECE($GET(^DIC(11,+$PIECE(SD(0),U,5),0)),U),X,SDSECCOL,20)
+6 DO SET(X)
PTSEX ; Sex and Religions Pref. Info
+1 ;
+2 SET X=""
SET X=$$SETSTR^VALM1("Sex:",X,17,4)
+3 SET X=$$SETSTR^VALM1($SELECT($PIECE(SD(0),U,2)="F":"FEMALE",$PIECE(SD(0),U,2)="M":"MALE",1:"UNKNOWN"),X,SDFSTCOL,18)
+4 SET X=$$SETSTR^VALM1("Religious Pref.:",X,43,16)
+5 SET X=$$SETSTR^VALM1($PIECE($GET(^DIC(13,+$PIECE(SD(0),U,8),0)),U),X,SDSECCOL,20)
+6 DO SET(X)
PTRACE ; SSN and Occupation Info
+1 ;
+2 SET X=""
SET X=$$SETSTR^VALM1("Patient ID:",X,10,11)
+3 SET X=$$SETSTR^VALM1(VA("PID"),X,SDFSTCOL,20)
+4 SET X=$$SETSTR^VALM1("Occupation:",X,48,11)
+5 SET X=$$SETSTR^VALM1($PIECE(SD(0),U,7),X,SDSECCOL,20)
+6 DO SET(X)
PWHO ; Who entered and Place of Birth
+1 ;
+2 SET X=""
SET X=$$SETSTR^VALM1("Who entered:",X,9,12)
+3 SET X=$$SETSTR^VALM1($PIECE($GET(^VA(200,+$PIECE(SD(0),U,15),0)),U),X,SDFSTCOL,20)
+4 SET X=$$SETSTR^VALM1("Place of Birth:",X,44,15)
+5 SET X=$$SETSTR^VALM1(($PIECE(SD(0),U,11)_$SELECT($PIECE(SD(0),U,12):", ",1:"")_$PIECE($GET(^DIC(5,+$PIECE(SD(0),U,12),0)),U)),X,SDSECCOL,20)
+6 DO SET(X)
PWHEN ; Date entered
+1 SET X=""
SET X=$$SETSTR^VALM1("Date entered:",X,8,13)
+2 SET X=$$SETSTR^VALM1($SELECT($PIECE(SD(0),U,16):$TRANSLATE($$FMTE^XLFDT($PIECE(SD(0),U,16),"5DF")," ","0"),1:""),X,SDFSTCOL,20)
+3 DO SET(X)
MT ; Current Means Test - if applicable
+1 ;
+2 SET X=""
IF SD("MT")'=""
Begin DoDot:1
+3 SET X=$$SETSTR^VALM1("Current Means Test:",X,2,19)
+4 SET X=$$SETSTR^VALM1($PIECE(SD("MT"),U,3),X,SDFSTCOL,30)
+5 SET X=$$SETSTR^VALM1("Date Means Test:",X,43,16)
+6 SET X=$$SETSTR^VALM1($TRANSLATE($$FMTE^XLFDT($PIECE(SD("MT"),U,2),"5DF")," ","0"),X,SDSECCOL,20)
End DoDot:1
+7 IF $DATA(SDCOPS)
IF +SDCOPS
Begin DoDot:1
+8 SET X=$$SETSTR^VALM1("Current Co-Pay Test:",X,1,20)
+9 SET X=$$SETSTR^VALM1($PIECE(SDCOPS,U,3),X,SDFSTCOL,30)
+10 SET X=$$SETSTR^VALM1("Date Co-Pay Test:",X,42,17)
+11 SET X=$$SETSTR^VALM1($TRANSLATE($$FMTE^XLFDT($PIECE(SDCOPS,U,2),"5DF")," ","0"),X,SDSECCOL,20)
End DoDot:1
+12 DO SET(X)
+1 SET X=""
IF $PIECE(SD(0),U,10)'=""
Begin DoDot:1
+2 SET X=$$SETSTR^VALM1("Remarks:",X,13,8)
+3 SET X=$$SETSTR^VALM1($PIECE(SD(0),U,10),X,SDFSTCOL,60)
End DoDot:1
+4 DO SET(X)
PRIME ; Primary Eligibility
+1 ;
+2 SET X=""
SET X=$$SETSTR^VALM1("Primary Eligibility:",X,1,20)
+3 SET X=$$SETSTR^VALM1($$FELIG(SD(.36)),X,SDFSTCOL,30)
+4 DO SET(X)
OTHERE ; Other Eligibilities and Date of Death
+1 ;
+2 SET X=""
SET X=$$SETSTR^VALM1("Other Eligibilities:",X,1,20)
+3 IF $PIECE(SD(.35),U)'=""
SET X=$$SETSTR^VALM1("Date of Death:",X,45,14)
SET X=$$SETSTR^VALM1($TRANSLATE($$FMTE^XLFDT($PIECE(SD(.35),U),"5DF")," ","0"),X,SDSECCOL,20)
+4 DO SET(X)
VET ; List of other eligibilities and VETERAN(Y/N)
+1 SET SDELIG=0
FOR
SET SDELIG=$ORDER(SDELIG(SDELIG))
if 'SDELIG
QUIT
SET SDCT=$GET(SDCT)+1
SET ROU=$SELECT(SDCT=1:"OTH1",SDCT=2:"OTH2",1:"OTHM")
DO @ROU
IF SDCT=5
SET X=""
SET X=$$SETSTR^VALM1("(this patient has more 'other eligibilities that are not listed)",X,10,65)
DO SET(X)
QUIT
+2 IF '$DATA(SDCT)
Begin DoDot:1
+3 SET X=""
SET X=$$SETSTR^VALM1("VETERAN(Y/N):",X,46,13)
+4 SET X=$$SETSTR^VALM1($SELECT(SD("VET")="N":"NO",SD("VET")="Y":"YES",1:"UNKNOWN"),X,SDSECCOL,7)
+5 DO SET(X)
+6 SET X=""
SET X=$$SETSTR^VALM1("Type:",X,54,5)
+7 SET X=$$SETSTR^VALM1($PIECE($GET(^DG(391,+SD("TYPE"),0)),U),X,SDSECCOL,20)
+8 DO SET(X)
End DoDot:1
+9 FOR SD=SDLN:1:12
DO SET("")
+10 DO ^SDPPAT2
+11 SET VALMCNT=SDLN
+12 QUIT
SET(X) ; Set in ^TMP global for display
+1 ;
+2 SET SDLN=$GET(SDLN)+1
SET ^TMP("SDPP",$JOB,SDLN,0)=X
+3 QUIT
OTH1 ; First 'Other' Eligibility' and VETERAN(Y/N)
+1 SET X=""
SET X=$$SETSTR^VALM1($$FELIG(SDELIG(SDELIG)),X,10,30)
+2 SET X=$$SETSTR^VALM1("VETERAN(Y/N):",X,46,13)
+3 SET X=$$SETSTR^VALM1($SELECT(SD("VET")="N":"NO",SD("VET")="Y":"YES",1:"UNKNOWN"),X,SDSECCOL,7)
+4 DO SET(X)
+5 QUIT
OTH2 ; Second 'Other Eligbility' and TYPE
+1 SET X=""
SET X=$$SETSTR^VALM1($$FELIG(SDELIG(SDELIG)),X,10,30)
+2 SET X=$$SETSTR^VALM1("Type:",X,53,5)
+3 SET X=$$SETSTR^VALM1($PIECE($GET(^DG(391,+SD("TYPE"),0)),U),X,SDSECCOL,20)
+4 DO SET(X)
+5 QUIT
OTHM ; Rest of 'Other Eligibilities'
+1 if SDCT>4
QUIT
+2 SET X=""
SET X=$$SETSTR^VALM1($$FELIG(SDELIG(SDELIG)),X,10,30)
+3 DO SET(X)
+4 QUIT
FELIG(ELIG) ;
+1 ; input - pointer to eligibility file
+2 ; output - name of eligibility
+3 QUIT $PIECE($GET(^DIC(8,+ELIG,0)),U)
