- IBDFFT2 ;ALB/MAF - FORMS TRACKING ; JUL 6 1995@800
- ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
- ;
- ;
- S IBDCNT1=IBDCNT1+1
- S IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
- S X=""
- S IBDFDIV(IBDFDV)=IBDCNT
- S X=$$SETSTR^VALM1(" ",X,1,3) D TMP1
- S X="",IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
- S IBDVAL=IBDFDV
- S IBDVAL1=$L(IBDVAL) S IBDVAL1=(80-IBDVAL1)/2 S IBDVAL1=IBDVAL1\1 S X=$$SETSTR^VALM1(" ",X,1,IBDVAL1)
- S X=$$SETSTR^VALM1(IBDVAL,X,IBDVAL1,25) D TMP1,CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM,0)
- S X="",IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
- S X=$$SETSTR^VALM1(" ",X,1,3) D TMP1
- S IBDCNT1=IBDCNT1-1
- Q
- TMP1 ; -- Set up TMP Array
- S ^TMP("FRM",$J,IBDCNT,0)=X,^TMP("FRM",$J,"IDX",VALMCNT,IBDCNT1)=""
- S ^TMP("FRMIDX",$J,IBDCNT1)=VALMCNT
- Q
- ;
- ;
- S IBDCNT1=IBDCNT1+1
- S IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
- S X=""
- I $D(VAUTG) S IBDFCLIN(IBDFGR,IBDFCL)=IBDCNT
- I '$D(VAUTG) S IBDFCLIN(IBDFDV,IBDFCL)=IBDCNT
- S X=$$SETSTR^VALM1(" ",X,1,3) D TMP1
- S X="",IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
- S IBDVAL=IBDFCL
- S X=$$SETSTR^VALM1(IBDVAL,X,1,25) D TMP1,CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM,0)
- S IBDCNT1=IBDCNT1-1
- Q
- S IBDCNT1=IBDCNT1+1
- S IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
- S X=""
- S IBDFGROP(IBDFDV,IBDFGR)=IBDCNT
- S X=$$SETSTR^VALM1(" ",X,1,3) D TMP1
- S X="",IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
- ;S IBDVAL=$P(^IBD(357.99,IBDFGR,0),"^",1)
- S IBDVAL=IBDFGR
- S IBDVAL1=$L(IBDVAL) S IBDVAL1=(80-IBDVAL1)/2 S IBDVAL1=IBDVAL1\1 S X=$$SETSTR^VALM1(" ",X,1,IBDVAL1)
- S X=$$SETSTR^VALM1(IBDVAL,X,IBDVAL1,25) D TMP1,CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM,0)
- S X="",IBDCNT=IBDCNT+1,VALMCNT=VALMCNT+1
- S X=$$SETSTR^VALM1(" ",X,1,3) D TMP1
- S IBDCNT1=IBDCNT1-1
- Q
- NUL ; -- NULL MESSAGE
- S ^TMP("FRM",$J,1,0)=" ",^TMP("FRM",$J,2,0)="There are no encounter forms that meet this criteria.",^TMP("FRMIDX",$J,1)=1,^TMP("FRMIDX",$J,2)=2
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFFT2 2031 printed Feb 19, 2025@00:19 Page 2
- IBDFFT2 ;ALB/MAF - FORMS TRACKING ; JUL 6 1995@800
- +1 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
- +2 ;
- +3 ;
- +1 SET IBDCNT1=IBDCNT1+1
- +2 SET IBDCNT=IBDCNT+1
- SET VALMCNT=VALMCNT+1
- +3 SET X=""
- +4 SET IBDFDIV(IBDFDV)=IBDCNT
- +5 SET X=$$SETSTR^VALM1(" ",X,1,3)
- DO TMP1
- +6 SET X=""
- SET IBDCNT=IBDCNT+1
- SET VALMCNT=VALMCNT+1
- +7 SET IBDVAL=IBDFDV
- +8 SET IBDVAL1=$LENGTH(IBDVAL)
- SET IBDVAL1=(80-IBDVAL1)/2
- SET IBDVAL1=IBDVAL1\1
- SET X=$$SETSTR^VALM1(" ",X,1,IBDVAL1)
- +9 SET X=$$SETSTR^VALM1(IBDVAL,X,IBDVAL1,25)
- DO TMP1
- DO CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM,0)
- +10 SET X=""
- SET IBDCNT=IBDCNT+1
- SET VALMCNT=VALMCNT+1
- +11 SET X=$$SETSTR^VALM1(" ",X,1,3)
- DO TMP1
- +12 SET IBDCNT1=IBDCNT1-1
- +13 QUIT
- TMP1 ; -- Set up TMP Array
- +1 SET ^TMP("FRM",$JOB,IBDCNT,0)=X
- SET ^TMP("FRM",$JOB,"IDX",VALMCNT,IBDCNT1)=""
- +2 SET ^TMP("FRMIDX",$JOB,IBDCNT1)=VALMCNT
- +3 QUIT
- +4 ;
- +5 ;
- +1 SET IBDCNT1=IBDCNT1+1
- +2 SET IBDCNT=IBDCNT+1
- SET VALMCNT=VALMCNT+1
- +3 SET X=""
- +4 IF $DATA(VAUTG)
- SET IBDFCLIN(IBDFGR,IBDFCL)=IBDCNT
- +5 IF '$DATA(VAUTG)
- SET IBDFCLIN(IBDFDV,IBDFCL)=IBDCNT
- +6 SET X=$$SETSTR^VALM1(" ",X,1,3)
- DO TMP1
- +7 SET X=""
- SET IBDCNT=IBDCNT+1
- SET VALMCNT=VALMCNT+1
- +8 SET IBDVAL=IBDFCL
- +9 SET X=$$SETSTR^VALM1(IBDVAL,X,1,25)
- DO TMP1
- DO CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM,0)
- +10 SET IBDCNT1=IBDCNT1-1
- +11 QUIT
- +1 SET IBDCNT1=IBDCNT1+1
- +2 SET IBDCNT=IBDCNT+1
- SET VALMCNT=VALMCNT+1
- +3 SET X=""
- +4 SET IBDFGROP(IBDFDV,IBDFGR)=IBDCNT
- +5 SET X=$$SETSTR^VALM1(" ",X,1,3)
- DO TMP1
- +6 SET X=""
- SET IBDCNT=IBDCNT+1
- SET VALMCNT=VALMCNT+1
- +7 ;S IBDVAL=$P(^IBD(357.99,IBDFGR,0),"^",1)
- +8 SET IBDVAL=IBDFGR
- +9 SET IBDVAL1=$LENGTH(IBDVAL)
- SET IBDVAL1=(80-IBDVAL1)/2
- SET IBDVAL1=IBDVAL1\1
- SET X=$$SETSTR^VALM1(" ",X,1,IBDVAL1)
- +10 SET X=$$SETSTR^VALM1(IBDVAL,X,IBDVAL1,25)
- DO TMP1
- DO CNTRL^VALM10(VALMCNT,1,80,IOINHI,IOINORM,0)
- +11 SET X=""
- SET IBDCNT=IBDCNT+1
- SET VALMCNT=VALMCNT+1
- +12 SET X=$$SETSTR^VALM1(" ",X,1,3)
- DO TMP1
- +13 SET IBDCNT1=IBDCNT1-1
- +14 QUIT
- NUL ; -- NULL MESSAGE
- +1 SET ^TMP("FRM",$JOB,1,0)=" "
- SET ^TMP("FRM",$JOB,2,0)="There are no encounter forms that meet this criteria."
- SET ^TMP("FRMIDX",$JOB,1)=1
- SET ^TMP("FRMIDX",$JOB,2)=2
- +2 QUIT