- YSFORM ;SLC/TGA-HEADER & FOOTER FOR FORMS ;3/27/90 15:01 ;
- ;;5.01;MENTAL HEALTH;**187**;Dec 30, 1994;Build 73
- ;
- ENHD ; Called by routines YSDX3R, YSDX3R1, YSDX3RU, YSDSR, YSHX1R YSPDR1
- ; YSPDXR, YSPHYR, YSPP, YSPP1, YSPP1A, YSPP3, YSPP4, YSPP5, YSPP6
- ; YSPP7, YSPP8, YSPP9, YSPRBR1, YSPRBR2, YSPROB5, YSPROBR, YSPROSE
- ; YSPTXR
- ;Generates page header
- S:'$D(YSCON) YSCON=0 S:'$D(YSFTR) YSFTR="" S:'$D(YSFHDR(1)) YSFHDR(1)="" W @IOF
- S:'$D(YSLCN) YSLCN=$$SITE,YSLCN="VAMC "_YSLCN
- I IOST?1"C-".E W YSNM,?47,"SSN ",$$MASKSSN(YSSSN),?65,"DOB ",YSDOB,!
- I IOST?1"P".E W ! F I0=1:1:80 W "-"
- I IOST?1"P".E W ! W:YSFTR]"" "MEDICAL RECORD"
- W ?80-$L(YSFHDR)/2,YSFHDR I IOST?1"P".E W ! F I0=1:1:IOM W "-"
- W:YSCON !?25,"(Continued from previous page)" X:YSFHDR(1)]"" YSFHDR(1)
- K I0 S YSCON=0 Q
- ;
- ENFT ; Called by routines YSDX3R1, YSDX3RU, YSDXR, YSHX1R YSPDR1
- ; YSPDXR, YSPHYR, YSPP, YSPP1, YSPP1A, YSPP3, YSPP4, YSPP5
- ; YSPP7, YSPP8, YSPP9, YSPRBR1, YSPRBR2, YSPROB5, YSPROBR1, YSPROSE
- ; YSPTXR
- ;Generates page footer
- S:'$D(YSFTR) YSFTR="" S:'$D(YSCON) YSCON=0
- S:'$D(YSLCN) YSLCN=$$SITE,YSLCN="VAMC "_YSLCN
- F I0=1:1:(IOSL-$Y-9) W !
- W ! W:YSCON ?28,"(Continued on next page)"
- W ! F I0=1:1:IOM W "_"
- W !,YSNM,?(31+(37-$L(YSLCN)/2)),YSLCN W:YSFTR]"" ?69,"VAF 10-9034"
- I YSFTR]"" S YSFTR(1)="(VICE "_YSFTR_")"
- W !,$$MASKSSN(YSSSN) W:YSDOB]"" " DOB ",YSDOB W:YSFTR]"" ?(80-$L(YSFTR(1))),YSFTR(1)
- W:IOST?1"P".E ! K I0 Q
- ;
- SITE() ;Set YSLOC to location using KERNEL site parameter file entry
- N DIC,DA,DIQ,DR
- S YSDA=+$P(^XMB(1,1,"XUS"),U,17)
- S DIC=4,DR=".01",DA=YSDA,DIQ(0)="EN",DIQ="YSLOC" D EN^DIQ1
- S YSLOC=$P(YSLOC(4,+YSDA,.01,"E"),",")
- QUIT YSLOC
- ;
- MASKSSN(YSSSN) ; return only last 4 of SSN
- Q "xxx-xx-"_$E(YSSSN,$L(YSSSN)-3,$L(YSSSN))
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYSFORM 1807 printed Jan 18, 2025@03:15:36 Page 2
- YSFORM ;SLC/TGA-HEADER & FOOTER FOR FORMS ;3/27/90 15:01 ;
- +1 ;;5.01;MENTAL HEALTH;**187**;Dec 30, 1994;Build 73
- +2 ;
- ENHD ; Called by routines YSDX3R, YSDX3R1, YSDX3RU, YSDSR, YSHX1R YSPDR1
- +1 ; YSPDXR, YSPHYR, YSPP, YSPP1, YSPP1A, YSPP3, YSPP4, YSPP5, YSPP6
- +2 ; YSPP7, YSPP8, YSPP9, YSPRBR1, YSPRBR2, YSPROB5, YSPROBR, YSPROSE
- +3 ; YSPTXR
- +4 ;Generates page header
- +5 if '$DATA(YSCON)
- SET YSCON=0
- if '$DATA(YSFTR)
- SET YSFTR=""
- if '$DATA(YSFHDR(1))
- SET YSFHDR(1)=""
- WRITE @IOF
- +6 if '$DATA(YSLCN)
- SET YSLCN=$$SITE
- SET YSLCN="VAMC "_YSLCN
- +7 IF IOST?1"C-".E
- WRITE YSNM,?47,"SSN ",$$MASKSSN(YSSSN),?65,"DOB ",YSDOB,!
- +8 IF IOST?1"P".E
- WRITE !
- FOR I0=1:1:80
- WRITE "-"
- +9 IF IOST?1"P".E
- WRITE !
- if YSFTR]""
- WRITE "MEDICAL RECORD"
- +10 WRITE ?80-$LENGTH(YSFHDR)/2,YSFHDR
- IF IOST?1"P".E
- WRITE !
- FOR I0=1:1:IOM
- WRITE "-"
- +11 if YSCON
- WRITE !?25,"(Continued from previous page)"
- if YSFHDR(1)]""
- XECUTE YSFHDR(1)
- +12 KILL I0
- SET YSCON=0
- QUIT
- +13 ;
- ENFT ; Called by routines YSDX3R1, YSDX3RU, YSDXR, YSHX1R YSPDR1
- +1 ; YSPDXR, YSPHYR, YSPP, YSPP1, YSPP1A, YSPP3, YSPP4, YSPP5
- +2 ; YSPP7, YSPP8, YSPP9, YSPRBR1, YSPRBR2, YSPROB5, YSPROBR1, YSPROSE
- +3 ; YSPTXR
- +4 ;Generates page footer
- +5 if '$DATA(YSFTR)
- SET YSFTR=""
- if '$DATA(YSCON)
- SET YSCON=0
- +6 if '$DATA(YSLCN)
- SET YSLCN=$$SITE
- SET YSLCN="VAMC "_YSLCN
- +7 FOR I0=1:1:(IOSL-$Y-9)
- WRITE !
- +8 WRITE !
- if YSCON
- WRITE ?28,"(Continued on next page)"
- +9 WRITE !
- FOR I0=1:1:IOM
- WRITE "_"
- +10 WRITE !,YSNM,?(31+(37-$LENGTH(YSLCN)/2)),YSLCN
- if YSFTR]""
- WRITE ?69,"VAF 10-9034"
- +11 IF YSFTR]""
- SET YSFTR(1)="(VICE "_YSFTR_")"
- +12 WRITE !,$$MASKSSN(YSSSN)
- if YSDOB]""
- WRITE " DOB ",YSDOB
- if YSFTR]""
- WRITE ?(80-$LENGTH(YSFTR(1))),YSFTR(1)
- +13 if IOST?1"P".E
- WRITE !
- KILL I0
- QUIT
- +14 ;
- SITE() ;Set YSLOC to location using KERNEL site parameter file entry
- +1 NEW DIC,DA,DIQ,DR
- +2 SET YSDA=+$PIECE(^XMB(1,1,"XUS"),U,17)
- +3 SET DIC=4
- SET DR=".01"
- SET DA=YSDA
- SET DIQ(0)="EN"
- SET DIQ="YSLOC"
- DO EN^DIQ1
- +4 SET YSLOC=$PIECE(YSLOC(4,+YSDA,.01,"E"),",")
- +5 QUIT YSLOC
- +6 ;
- MASKSSN(YSSSN) ; return only last 4 of SSN
- +1 QUIT "xxx-xx-"_$EXTRACT(YSSSN,$LENGTH(YSSSN)-3,$LENGTH(YSSSN))