Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SCDXUTL1

SCDXUTL1.m

Go to the documentation of this file.
  1. SCDXUTL1 ;ALB/JRP - GENERAL UTILITY ROUTINES;10-MAY-1996
  1. ;;5.3;Scheduling;**44,60,132**;AUG 13, 1993
  1. ;
  1. GETDTRNG(EARLIEST,LATEST,HELPBGN,HELPEND) ;Prompt user for a date range
  1. ;
  1. ;Input : EARLIEST - Earliest date allowed in FileMan format (Optional)
  1. ; LATEST - Latest date allowed in FileMan format (Optional)
  1. ; HELPBGN - Array containing help information for beginning
  1. ; date (Full global reference) (Optional)
  1. ; HELPEND - Array containing help information for ending
  1. ; date (Full global reference) (Optional)
  1. ;Output : Begin^End - Success
  1. ; Begin - Beginning date
  1. ; End - Ending date
  1. ; -1 - User abort / timed out
  1. ;Notes : HELPBGN & HELPEND arrays have same format as DIR("?",#) array
  1. ;
  1. ;Check input
  1. S EARLIEST=$G(EARLIEST)
  1. S LATEST=$G(LATEST)
  1. S HELPBGN=$G(HELPBGN)
  1. S HELPEND=$G(HELPEND)
  1. ;Declare variables
  1. N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,BEGIN,END
  1. ;Get beginning date
  1. S DIR(0)="DA^"_EARLIEST_":"_LATEST_":EPX"
  1. S DIR("A")="Enter beginning date: "
  1. I (HELPBGN'="") M DIR("?")=@HELPBGN
  1. D ^DIR
  1. S BEGIN=+Y
  1. ;User abort / time out
  1. Q:($D(DIRUT)) -1
  1. ;Get ending date
  1. K DIR
  1. S DIR(0)="DA^"_BEGIN_":"_LATEST_":EPX"
  1. S DIR("A")="Enter ending date: "
  1. I (HELPEND'="") M DIR("?")=@HELPEND
  1. D ^DIR
  1. S END=+Y
  1. ;User abort / time out
  1. Q:($D(DIRUT)) -1
  1. ;Done
  1. Q BEGIN_"^"_END
  1. ;
  1. REPEAT(CHAR,TIMES) ;Repeat a string
  1. ;INPUT : CHAR - Character to repeat
  1. ; TIMES - Number of times to repeat CHAR
  1. ;OUTPUT : s - String of CHAR that is TIMES long
  1. ; "" - Error (bad input)
  1. ;
  1. ;Check input
  1. Q:($G(CHAR)="") ""
  1. Q:((+$G(TIMES))=0) ""
  1. ;Return string
  1. Q $TR($J("",TIMES)," ",CHAR)
  1. ;
  1. INSERT(INSTR,OUTSTR,COLUMN,LENGTH) ;Insert a string into another string
  1. ;INPUT : INSTR - String to insert
  1. ; OUTSTR - String to insert into
  1. ; COLUMN - Where to begin insertion (defaults to end of OUTSTR)
  1. ; LENGTH - Number of characters to clear from OUTSTR
  1. ; (defaults to length of INSTR)
  1. ;OUTPUT : s - INSTR will be placed into OUTSTR starting at COLUMN
  1. ; using LENGTH characters
  1. ; "" - Error (bad input)
  1. ;
  1. ;NOTE : This module is based on $$SETSTR^VALM1
  1. ;
  1. ;Check input
  1. S INSTR=$G(INSTR)
  1. Q:(INSTR="") $G(OUTSTR)
  1. S OUTSTR=$G(OUTSTR)
  1. S:('$D(COLUMN)) COLUMN=$L(OUTSTR)+1
  1. S:('$D(LENGTH)) LENGTH=$L(INSTR)
  1. ;Declare variables
  1. N FRONT,END
  1. S FRONT=$E((OUTSTR_$J("",COLUMN-1)),1,(COLUMN-1))
  1. S END=$E(OUTSTR,(COLUMN+LENGTH),$L(OUTSTR))
  1. ;Insert string
  1. Q FRONT_$E((INSTR_$J("",LENGTH)),1,LENGTH)_END
  1. ;
  1. DIAG(SDPOE,SCDXARRY) ;Get diagnoses from V POV file
  1. ; Note: Returns Dx from children (if any)
  1. ;
  1. ; SDPOE - pointer to 409.68
  1. ; SCDGARRY - output array
  1. ;
  1. N SCOPDX,SDCHILD,SDOE
  1. D KIDS(SDPOE,"SDCHILD")
  1. ;
  1. ; -- get parent dxs
  1. D GETDX^SDOE(+$G(SDPOE),SCDXARRY)
  1. ;
  1. ; -- get child dxs
  1. S SDOE=0
  1. F S SDOE=$O(SDCHILD(SDOE)) Q:'SDOE D
  1. . D GETDX^SDOE(SDOE,SCDXARRY)
  1. Q
  1. ;
  1. PRIMPDX(SDPOE) ; return pointer to ICD9 for primary dx of parent encounter
  1. ; Note: Includes
  1. ; SDPOE - encounter (parent)
  1. ; return:
  1. ; if one: ptr to ICD DIAGNOSIS file (ICD9)^pointer to V POV file
  1. ; if none: no prim dx
  1. ; if two+: -1 (error)
  1. ;
  1. N SCDX,SCX,SCDX1,SDCHILD,SDOE
  1. S SCDX1=0
  1. D DIAG(.SDPOE,"SCDX")
  1. S SCX=0
  1. F S SCX=$O(SCDX(SCX)) Q:'SCX IF $P(SCDX(SCX),U,12)="P" S:SCDX1 SCDX1=-1 Q:SCDX1 S SCDX1=(+SCDX(SCX))_U_SCX
  1. Q SCDX1
  1. ;
  1. KIDS(SDOE,SCKIDS) ;return children of parent
  1. ; Input - SDOE = ptr to 409.68
  1. ; Output- @SCKIDS@(kid ptr to 409.68) array
  1. N SCX
  1. S SCX=0 F S SCX=$O(^SCE("APAR",SDOE,SCX)) Q:'SCX S @SCKIDS@(SCX)=""
  1. Q