Routine: SDPPAT1

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)

REMARK ; Remark

 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

SET(X) ; Set in ^TMP global for display

 S SDLN=$G(SDLN)+1,^TMP("SDPP",$J,SDLN,0)=X

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)

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)

OTHM ; Rest of 'Other Eligibilities'

 Q:SDCT>4

 S X="",X=$$SETSTR^VALM1($$FELIG(SDELIG(SDELIG)),X,10,30)

 D SET(X)

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  Feb 19, 2025@00:26:12                                                                                                                                                                                                     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)

REMARK    ; Remark

 +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)

SDPPAT1.m