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

SCAPMCU1.m

Go to the documentation of this file.
  1. SCAPMCU1 ;ALB/REW - TEAM API UTILITIES ; 7/12/99 9:33am ;07/06/2017
  1. ;;5.3;Scheduling;**41,45,48,177,666**;AUG 13, 1993;Build 4
  1. ;;1.0
  1. INIT(SCOK) ; setup date array & error arrays if none passed in
  1. ; VARIABLES SET:
  1. ; SCOK - SET TO 0 IF ERROR
  1. ;
  1. ; Makes sure the following are defined:
  1. ; scbegin,scend,scincl,@scdates('begin'),@scdates@('end'),@scdates@('incl') - defaults are today & inclusive
  1. ;
  1. ; Note: you should NEW the above just before making this call
  1. ; ---
  1. N SCNOW ;666
  1. S (SCN,SCESEQ,SCLSEQ)=0
  1. IF '$L($G(SCERR)) K ^TMP("SCERR",$J) S SCERR="^TMP(""SCERR"",$J)"
  1. IF '$L($G(SCLIST)) S SCLIST="^TMP(""SC TMP LIST"",$J)" K ^TMP("SC TMP LIST",$J)
  1. IF (SCERR="SCERR")!(SCERR="SCLIST")!((SCERR'?1A1.7AN)&(SCERR'?1"^"1A.20E)) D S SCOK=0
  1. . S SCPARM("ERROR ARRAY")=$G(SCERR,"Undefined")
  1. . D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
  1. IF SCLIST="SCERR"!(SCLIST="SCLIST")!((SCLIST'?1A1.7AN.1"(".60E)&(SCLIST'?1"^"1A1.7AN.1"(".60E)) S SCOK=0 D S SCOK=0
  1. . S SCPARM("OUTPUT ARRAY")=$G(SCLIST,"Undefined")
  1. . D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
  1. S:'$D(SCDATES)!($G(SCDATES)="") SCDATES="SCDTS"
  1. S SCNOW=$$NOW^XLFDT ;666
  1. S SCBEGIN=$G(@SCDATES@("BEGIN"),SCNOW),SCBEGIN=$S(SCBEGIN:SCBEGIN,1:SCNOW) ;666
  1. S SCEND=$G(@SCDATES@("END"),SCNOW),SCEND=$S(SCEND:SCEND,1:SCNOW) ;666
  1. S SCINCL=$G(@SCDATES@("INCL"),1)
  1. S (SCN,SCESEQ,SCLSEQ)=0
  1. S:'$D(@SCDATES@("BEGIN")) @SCDATES@("BEGIN")=SCBEGIN
  1. S:'$D(@SCDATES@("END")) @SCDATES@("END")=SCEND
  1. S:'$D(@SCDATES@("INCL")) @SCDATES@("INCL")=SCINCL
  1. Q
  1. ;
  1. ; bp/cmf 177 - added SCFUTURE input param, used at PCPOSCNT+17
  1. ;;bp/cmf 177; orig entry call; PCPOSCNT(SCTP,SCDATE,SCPCONLY);this is a more efficient count of PC patients assigned to position
  1. PCPOSCNT(SCTP,SCDATE,SCPCONLY,SCFUTURE) ;this is a more efficient count of PC patients assigned to position
  1. ; Input: SCTP - ien to 404.57
  1. ; SCDATE - date of concern, default=DT
  1. ; SCPCONLY - 1= must be pc, 0=all assignments 1=DEFAULT
  1. ; SCFUTURE - 1= include future, 0=current 0=DEFAULT ;;bp/cmf 177
  1. ;returns count of patient assignments or -1 if error
  1. N SCPTPA,SCCNT,SCHSTIEN,SCNODE
  1. Q:'$G(SCTP) -1
  1. S SCDATE=$G(SCDATE,DT)
  1. S:'$L($G(SCPCONLY)) SCPCONLY=1
  1. S:'$L($G(SCFUTURE)) SCFUTURE=0 ;;bp/cmf 177 add
  1. S (SCPTPA,SCCNT)=0
  1. F S SCPTPA=$O(^SCPT(404.43,"APTPA",SCTP,SCPTPA)) Q:'SCPTPA D
  1. .S SCHSTIEN=0
  1. .F S SCHSTIEN=$O(^SCPT(404.43,"APTPA",SCTP,SCPTPA,SCHSTIEN)) Q:'SCHSTIEN D
  1. ..S SCNODE=$G(^SCPT(404.43,SCHSTIEN,0))
  1. ..Q:$P(SCNODE,U,4)&($P(SCNODE,U,4)<SCDATE)
  1. ..;;bp/cmf 177;orig code;;Q:$P(SCNODE,U,3)>SCDATE
  1. ..Q:('SCFUTURE)&($P(SCNODE,U,3)>SCDATE) ;;bp/cmf 177 mod-use scfuture
  1. ..Q:SCPCONLY&('$P(SCNODE,U,5)) ;pc role is not 1 or 2
  1. ..S SCCNT=SCCNT+1
  1. Q SCCNT
  1. ;
  1. TEAMCNT(SCTM,DATE) ;this is a more efficient version of the count
  1. N DFN,SCCNT,SCNODE,HISTIEN
  1. Q:'$G(SCTM) 0
  1. S DATE=$G(DATE,DT)
  1. S (DFN,SCCNT)=0
  1. F S DFN=$O(^SCPT(404.42,"ATMPT",SCTM,DFN)) Q:'DFN D
  1. .S HISTIEN=0
  1. .F S HISTIEN=$O(^SCPT(404.42,"ATMPT",SCTM,DFN,HISTIEN)) Q:'HISTIEN D
  1. ..S SCNODE=$G(^SCPT(404.42,HISTIEN,0))
  1. ..Q:$P(SCNODE,U,9)&($P(SCNODE,U,9)<DATE)
  1. ..Q:$P(SCNODE,U,2)>DATE
  1. ..S SCCNT=SCCNT+1
  1. Q SCCNT
  1. ;
  1. TEAMCNT2(SCTM,DATE) ;this is the count of patients assigned to the team on a date
  1. ; Input: SCTM - ien to 404.51
  1. ; DATE - date of concern, default=DT
  1. N SCX,SCDATES,SCTEAMS,SCERR,X
  1. S SCDATES("BEGIN")=$G(DATE,DT)
  1. S SCDATES("END")=SCDATES("BEGIN")
  1. S SCX=$$PTTM^SCAPMC(SCTM,"SCDATES","^TMP(""SCTEAMS"",$J,""CNT"")","SCERRX")
  1. IF 'SCX S X=-SCX
  1. ELSE D
  1. .S DFN=0
  1. .F X=0:1 S DFN=$O(^TMP("SCTEAMS",$J,"CNT","SCPTA",DFN)) Q:'DFN
  1. K ^TMP("SCTEAMS",$J,"CNT")
  1. Q X
  1. ACTHISTB(FILE,IEN) ;boolean active function
  1. ;MOVED TO SCAPMCU2
  1. Q $$ACTHISTB^SCAPMCU2(.FILE,.IEN)
  1. ACTHIST(FILE,IEN,SCDATES,SCERR) ;is entry active for a time period?
  1. ;MOVED TO SCAPMCU2
  1. Q $$ACTHIST^SCAPMCU2(.FILE,.IEN,.SCDATES,.SCERR)
  1. ;
  1. LASTDATE(FILE,IEN) ;gets last date for team or position from 404.52,404.58,404.59 - uses DATES function below
  1. ; Input Parameters:
  1. ; File = either 404.52 or 404.58 or 404.59
  1. ; IEN = pointer to team(404.51) or team position(404.57)
  1. ; Returned:
  1. ; -1 if error,o/w latest date defined 0=no historical dates
  1. N SCX
  1. S SCX=$$DATES(.FILE,.IEN,3990101) ; gets dates as of 1/1/2999
  1. Q $S($P(SCX,U,1)<0:-1,$P(SCX,U,3):$P(SCX,U,3),1:+$P(SCX,U,2))
  1. ;
  1. DATES(FILE,IEN,DATE) ;used to return latest activation & inactivation date
  1. ; Input Parameters:
  1. ; File = either 404.52, 404.53, 404.58, or 404.59
  1. ; IEN = pointer to team(404.51) or team position(404.57)
  1. ; DATE = default=DT
  1. ; Returned:
  1. ; status^actdate^inactdate^scien^first actdate? [1=yes/null=no]
  1. ST N ROOT,EFFDT,STATUS,ACTDT,INACTDT,X,FUTURE,PREVDT,SCTODAY,PREVST,SCSTAT,SCIEN,SCLAST
  1. S:'$G(DATE) DATE=DT
  1. S STATUS=-1,SCTODAY=0
  1. S SCSTAT=1
  1. ;bp/cmf - 177 change begin
  1. G:('$G(FILE))!("^404.52^404.53^404.58^404.59^"'[$G(FILE))!('$G(IEN)) QTDATES
  1. ;orig;G:('$G(FILE))!("^404.52^404.58^404.59^"'[$G(FILE))!('$G(IEN)) QTDATES
  1. ;bp/cmf - 177 change begin
  1. S ROOT="^SCTM("_FILE_",""AIDT"",IEN,SCSTAT"
  1. S EFFDT=-DATE
  1. S X=ROOT_")"
  1. ;if there is an active x-ref
  1. IF $D(@X) D
  1. .;if today is an activation date
  1. .IF $D(@X@(EFFDT)) S ACTDT=-EFFDT
  1. .;if today is not an activation date get previous one
  1. .ELSE D
  1. ..S ACTDT=-$O(@X@(EFFDT))
  1. .;if no activation in past get one in future
  1. .S:'$G(ACTDT) ACTDT=-$O(@X@(EFFDT),-1),FUTURE=1
  1. .S SCSTAT=0
  1. .S INACTDT=$O(@X@(-(ACTDT-.000001)),-1),INACTDT=$S(INACTDT:-INACTDT,1:INACTDT)
  1. .S STATUS=$$DTCHK^SCAPU1(DATE,DATE,0,ACTDT,INACTDT)
  1. .S SCSTAT=STATUS
  1. .S X=ROOT_","_$S(SCSTAT:-ACTDT,1:-INACTDT)_")"
  1. .S SCIEN=$O(@X@(0))
  1. ELSE D
  1. .S STATUS=0
  1. QTDATES Q STATUS_U_$G(ACTDT)_U_$G(INACTDT)_U_$G(SCIEN)_U_$G(FUTURE)
  1. ;
  1. ERR(SEQ,ERNUM,PARMS,OUTPUT,SCER) ;-- process errors
  1. ;if no dialog entry 4040000 will be processed
  1. S ERNUM=$G(ERNUM,4040000)
  1. S:'$$GET1^DIQ(.84,$G(ERNUM)_",",.01) ERNUM=4040000
  1. IF SCER]"" D
  1. . S SEQ=$G(SEQ,0)+1
  1. . S SCER(SEQ)=ERNUM
  1. . ;S @SCER@(0)=$G(@SCER@(0))+1 ;bp/djb 7/12/99
  1. . S SCER(0)=$G(SCER(0))+1
  1. . ;D BLD^DIALOG(.ERNUM,.PARMS,.OUTPUT,.SCER) ;bp/djb 7/12/99
  1. . D BLD^DIALOG(.ERNUM,.PARMS,.OUTPUT,"SCER")
  1. Q
  1. ;
  1. OKTMPOS(TEAM,POSITION,DATE) ;validate legitimate position in a team for a dt
  1. ; used in screen for pc practitioner position of patient team assngt
  1. ;
  1. ; TEAM - ien of team file
  1. ; POSITION - ien of team position file
  1. ; DATE - date of interest
  1. ; return 1 if ok, 0 ow
  1. ;
  1. CHK ;
  1. N SCTP,SCOK,SCPOS0
  1. S SCOK=0
  1. S:'$L($G(SCERR)) SCERR="^TMP(""SCERR"",$J)"
  1. IF '$D(^SCTM(404.51,+$G(TEAM),0)) D G QTOKTP
  1. . S SCPARM("TEAM")=$G(TEAM,"Undefined")
  1. . D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
  1. IF '$D(^SCTM(404.57,+$G(POSITION),0)) D G QTOKTP
  1. . S SCPARM("POSITION")=$G(POSITION,"Undefined")
  1. . D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
  1. IF '$G(DATE) D G QTOKTP
  1. . S SCPARM("DATE")=$G(DATE,"Undefined")
  1. . D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
  1. S SCPOS0=$G(^SCTM(404.57,POSITION,0))
  1. ;if position not linked to team
  1. G QTOKTP:$P(SCPOS0,U,2)'=TEAM
  1. ;if not active position
  1. G QTOKTP:'$$DATES(404.59,POSITION,DATE)
  1. S SCOK=1
  1. QTOKTP Q SCOK
  1. RSNDICS(EVCODE) ; -- called by input transform and screen logic for type of reason
  1. ; Input: EVCODE = event code (e.g. ZM1)
  1. ; Used to check for fields that point to Scheduling Reason File
  1. ; Piece = Piece number of zero node of
  1. Q $P(^SD(403.43,$P(^(0),U,2),0),U,1)=EVCODE
  1. ;
  1. OKPREC(TEAM) ; - called by screen logic for preceptor position file (#.1) of team position (#404.57) file
  1. ; Input; TEAM = Pointer to team file (#404.51) for team position with preceptor
  1. ; requires position being assigned to be a possible preceptor position
  1. ; AND that position is from the same team as the supervised position
  1. Q ($P(^SCTM(404.57,Y,0),U,12))&($P(^SCTM(404.57,Y,0),U,2)=TEAM)