Ignore:
Timestamp:
Dec 4, 2009, 12:11:15 AM (15 years ago)
Author:
George Lilly
Message:

revised back to 6/30/08 version

Location:
WorldVistAEHR/trunk/r/SCHEDULING-SD-SC
Files:
68 edited

Legend:

Unmodified
Added
Removed

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCAPMC14.m

    r613 r623  
    1 SCAPMC14        ;ALB/REW - Team API's: PTPR ; JUN 30, 1995
    2         ;;5.3;Scheduling;**41,520**;AUG 13, 1993;Build 26
    3         ;;1.0
    4 PTPR(SC200,SCDATES,SCPURPA,SCROLEA,SCLIST,SCERR,SCYESCL)        ; -- list patients for a pract (scyescl NOT supported)
    5         ; input:
    6         ; SC200 = ien of NEW PERSON file(#200) [required]
    7         ;  SCDATES("BEGIN") = begin date to search (inclusive)
    8         ;                       [default: TODAY]
    9         ;        ("END")   = end date to search (inclusive)
    10         ;                      [default: TODAY]
    11         ;        ("INCL")  = 1: only use patients who were assigned to
    12         ;                       team for entire date range
    13         ;                    0: anytime in date range
    14         ;                      [default: 1]
    15         ;  SCPURPA -array of pointers to team purpose file 403.47
    16         ;          if none are defined - returns all teams
    17         ;          if @SCPURPA@('exclude') is defined - exclude listed teams
    18         ;  SCROLEA-array of pointer to 403.46 (per SCPURPA)
    19         ;  SCLIST -array name to store list
    20         ;          [ex. ^TMP("SCPT",$J)]
    21         ;       
    22         ;  SCERR = array NAME to store error messages.
    23         ;          [ex. ^TMP("ORXX",$J)]
    24         ;  SCYESCL = Boolean to indicate 1=use associated clinics 0=don't
    25         ;            default=0
    26         ;
    27         ;
    28         ; Output:
    29         ;  SCLIST() = array of patients
    30         ;             Format:
    31         ;               Subscript: Sequential # from 1 to n
    32         ;               Piece     Description
    33         ;                 1       IEN of PATIENT file entry
    34         ;                 2       Name of patient
    35         ;                 3       IEN of Pt Team Posit Asment if position=source
    36         ;                 4       Activation Date
    37         ;                 5       Inactivation Date
    38         ;                 6       Source 1=Clinic, Null=Position
    39         ;                 7       IEN of Clinic if clinic=source
    40         ;
    41         ;  SCERR() = Array of DIALOG file messages(errors) .
    42         ;  @SCERR@(0) = number of errors, undefined if none
    43         ;             Format:
    44         ;               Subscript: Sequential # from 1 to n
    45         ;               Piece     Description
    46         ;                 1       IEN of DIALOG file
    47         ;  Returned: 1 if ok, 0 if error
    48         ;
    49         ;
    50 ST      N SCTM,SCPTA,SCPTA0,SCOK,SCX,NODE,TPACT,TPINACT,SCTEMP,SCTP,SCUSR
    51         N SCLSEQ,SCN,SCESEQ,SCPARM,SCP,SCBEGIN,SCEND,SCINCL,SCDTS
    52         ; -- initialize control variables
    53         G:'$$OKDATA PRACQ
    54         ; -- get list of positions for practitioner
    55         G:'$$TPPR^SCAPMC(SC200,SCDATES,.SCPURPA,.SCROLEA,"SCTEMP",.SCERR) PRACQ
    56         G:'$G(SCTEMP(0)) PRACQ
    57         S SCTP=0
    58         ;get list of patients for each position
    59         F SCX=1:1 S NODE=$G(SCTEMP(SCX)),SCTP=+NODE Q:'SCTP  D  Q:'SCOK
    60         .S TPACT=$P(SCTEMP(SCX),U,5)
    61         .S TPINACT=$P(SCTEMP(SCX),U,6)
    62         .N SCDTPR
    63         .S SCDTPR("BEGIN")=$S(TPACT>@SCDATES@("BEGIN"):TPACT,1:@SCDATES@("BEGIN"))
    64         .S SCDTPR("END")=$S('TPINACT:@SCDATES@("END"),(TPINACT<@SCDATES@("END")):TPINACT,1:@SCDATES@("END"))
    65         .S SCDTPR("INCL")=@SCDATES@("INCL")
    66         .S SCOK=$$PTTP^SCAPMC(SCTP,"SCDTPR",.SCLIST,.SCERR)
    67         .Q:'SCOK
    68         .Q:'SCYESCL
    69         .;S SC44=$P($G(^SCTM(404.57,+SCTP,0)),U,9)
    70         .;Q:'SC44
    71         .N CNAME,SC44
    72         .D SETASCL^SCRPRAC2(SCTP,.CNAME,.SC44)
    73         .N SCCNT S SCCNT=0
    74         .F  S SCCNT=$O(SC44(SCCNT)) Q:SCCNT=""  S SCOK=$$PTCL^SCAPMC(SC44(SCCNT),"SCDTPR",.SCLIST,.SCERR)
    75 PRACQ   Q $G(@SCERR@(0))<1
    76         ;
    77 OKDATA()        ;setup/check variables
    78         N SCOK
    79         S SCOK=1
    80         S SCYESCL=$G(SCYESCL,0)
    81         D INIT^SCAPMCU1(.SCOK) ; set default dates & error array (if undefined)
    82         IF '$D(^VA(200,+$G(SC200),0)) D  S SCOK=0
    83         . S SCPARM("PRACT")=$G(SC200,"Undefined")
    84         . D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
    85         ; -- is it a valid DFN passed (Error # 20001 in DIALOG file)
    86         IF '$D(^VA(200,+SC200,0)) D   S SCOK=0
    87         . S SCPARM("PRACT")=SC200
    88         . D ERR^SCAPMCU1(SCESEQ,20001,.SCPARM,"",.SCERR)
    89         Q SCOK
    90         ;
     1SCAPMC14 ;ALB/REW - Team API's: PTPR ; JUN 30, 1995
     2 ;;5.3;Scheduling;**41**;AUG 13, 1993
     3 ;;1.0
     4PTPR(SC200,SCDATES,SCPURPA,SCROLEA,SCLIST,SCERR,SCYESCL) ; -- list patients for a pract (scyescl NOT supported)
     5 ; input:
     6 ; SC200 = ien of NEW PERSON file(#200) [required]
     7 ;  SCDATES("BEGIN") = begin date to search (inclusive)
     8 ;                       [default: TODAY]
     9 ;        ("END")   = end date to search (inclusive)
     10 ;                      [default: TODAY]
     11 ;        ("INCL")  = 1: only use patients who were assigned to
     12 ;                       team for entire date range
     13 ;                    0: anytime in date range
     14 ;                      [default: 1]
     15 ;  SCPURPA -array of pointers to team purpose file 403.47
     16 ;          if none are defined - returns all teams
     17 ;          if @SCPURPA@('exclude') is defined - exclude listed teams
     18 ;  SCROLEA-array of pointer to 403.46 (per SCPURPA)
     19 ;  SCLIST -array name to store list
     20 ;          [ex. ^TMP("SCPT",$J)]
     21 ;       
     22 ;  SCERR = array NAME to store error messages.
     23 ;          [ex. ^TMP("ORXX",$J)]
     24 ;  SCYESCL = Boolean to indicate 1=use associated clinics 0=don't
     25 ;            default=0
     26 ;
     27 ;
     28 ; Output:
     29 ;  SCLIST() = array of patients
     30 ;             Format:
     31 ;               Subscript: Sequential # from 1 to n
     32 ;               Piece     Description
     33 ;                 1       IEN of PATIENT file entry
     34 ;                 2       Name of patient
     35 ;                 3       IEN of Pt Team Posit Asment if position=source
     36 ;                 4       Activation Date
     37 ;                 5       Inactivation Date
     38 ;                 6       Source 1=Clinic, Null=Position
     39 ;                 7       IEN of Clinic if clinic=source
     40 ;
     41 ;  SCERR() = Array of DIALOG file messages(errors) .
     42 ;  @SCERR@(0) = number of errors, undefined if none
     43 ;             Format:
     44 ;               Subscript: Sequential # from 1 to n
     45 ;               Piece     Description
     46 ;                 1       IEN of DIALOG file
     47 ;  Returned: 1 if ok, 0 if error
     48 ;
     49 ;
     50ST N SCTM,SCPTA,SCPTA0,SCOK,SCX,NODE,TPACT,TPINACT,SCTEMP,SCTP,SCUSR
     51 N SCLSEQ,SCN,SCESEQ,SCPARM,SCP,SCBEGIN,SCEND,SCINCL,SCDTS
     52 ; -- initialize control variables
     53 G:'$$OKDATA PRACQ
     54 ; -- get list of positions for practitioner
     55 G:'$$TPPR^SCAPMC(SC200,SCDATES,.SCPURPA,.SCROLEA,"SCTEMP",.SCERR) PRACQ
     56 G:'$G(SCTEMP(0)) PRACQ
     57 S SCTP=0
     58 ;get list of patients for each position
     59 F SCX=1:1 S NODE=$G(SCTEMP(SCX)),SCTP=+NODE Q:'SCTP  D  Q:'SCOK
     60 .S TPACT=$P(SCTEMP(SCX),U,5)
     61 .S TPINACT=$P(SCTEMP(SCX),U,6)
     62 .N SCDTPR
     63 .S SCDTPR("BEGIN")=$S(TPACT>@SCDATES@("BEGIN"):TPACT,1:@SCDATES@("BEGIN"))
     64 .S SCDTPR("END")=$S('TPINACT:@SCDATES@("END"),(TPINACT<@SCDATES@("END")):TPINACT,1:@SCDATES@("END"))
     65 .S SCDTPR("INCL")=@SCDATES@("INCL")
     66 .S SCOK=$$PTTP^SCAPMC(SCTP,"SCDTPR",.SCLIST,.SCERR)
     67 .Q:'SCOK
     68 .Q:'SCYESCL
     69 .S SC44=$P($G(^SCTM(404.57,+SCTP,0)),U,9)
     70 .Q:'SC44
     71 .S SCOK=$$PTCL^SCAPMC(SC44,"SCDTPR",.SCLIST,.SCERR)
     72PRACQ Q $G(@SCERR@(0))<1
     73 ;
     74OKDATA() ;setup/check variables
     75 N SCOK
     76 S SCOK=1
     77 S SCYESCL=$G(SCYESCL,0)
     78 D INIT^SCAPMCU1(.SCOK) ; set default dates & error array (if undefined)
     79 IF '$D(^VA(200,+$G(SC200),0)) D  S SCOK=0
     80 . S SCPARM("PRACT")=$G(SC200,"Undefined")
     81 . D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
     82 ; -- is it a valid DFN passed (Error # 20001 in DIALOG file)
     83 IF '$D(^VA(200,+SC200,0)) D   S SCOK=0
     84 . S SCPARM("PRACT")=SC200
     85 . D ERR^SCAPMCU1(SCESEQ,20001,.SCPARM,"",.SCERR)
     86 Q SCOK
     87 ;

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCAPMC29.m

    r613 r623  
    1 SCAPMC29        ;ALB/REW - TEAM APIs:CLPT  ; 2/17/00 1:33pm
    2         ;;5.3;Scheduling;**41,210,520**;AUG 13, 1993;Build 26
    3         ;;1.0
    4 CLPT(DFN,SCDATES,SCTEAMA,SCLIST,SCERR)  ;clinics for patient
    5         ; input:
    6         ;  DFN = ien of PATIENT <FILE#2> [required]
    7         ;  SCDATES("BEGIN") = begin date to search (inclusive)
    8         ;                       [default: TODAY]
    9         ;         ("END")   = end date to search (inclusive)
    10         ;                       [default: TODAY]
    11         ;         ("INCL")  = 1: only use pracitioners who were on
    12         ;                       team for entire date range
    13         ;                     0: anytime in date range
    14         ;                      [default: 1]
    15         ;  SCTEAMA= array of teams to include reverse with scposa('exclude')
    16         ;  SCERR = array NAME to store error messages.
    17         ;          [ex. ^TMP("ORXX",$J)]
    18         ;
    19         ; Output:
    20         ;  SCLIST() = array of clinics
    21         ;             Format:
    22         ;               Subscript: Sequential # from 1 to n
    23         ;               Piece     Description
    24         ;                 1       IEN of HOSPITAL LOCATION file entry (#44)
    25         ;                 2       Name of CLINIC
    26         ;                 3       ENROLLMENT DATE
    27         ;                 4       DISCHARGE DATE
    28         ;                 5       OPT OR AC
    29         ;                 6       REVIEW DATE
    30         ;
    31         ;  SCERR()  = Array of DIALOG file messages(errors) .
    32         ;  @SCERR(0)= Number of error(s), UNDEFINED if no errors
    33         ;             Foramt:
    34         ;               Subscript: Sequential # from 1 to n
    35         ;               Piece     Description
    36         ;                 1       IEN of DIALOG file
    37         ;   Returned: 1 if ok, 0 if error
    38         ;
    39         ; -- initialize control variables
    40         ;
    41 ST      N SCX,SCS,SC44,SCACOPT,SCTM,SCPOSA,SCTP
    42         N SCLSEQ,SCN,SCESEQ,SCPARM,SCP,SCBEGIN,SCEND,SCINCL,SCDTS,SCOK,SCS,SCND,SCACT,SCINACT,SCREVDT,SCCLNM
    43         G:'$$OKDATA PTCLQ ; check/setup variables
    44         IF $L($G(SCTEAMA)) D
    45         .S SCTM=0
    46         .F  S SCTM=$O(@SCTEAMA@(SCTM)) Q:'SCTM  D  Q:'SCX
    47         ..S SCX=$$TPTM^SCAPMC(SCTM,SCDATES,,,"SCPOSAX",.SCERR)
    48         .F SCX=1:1 S SCTP=+$G(SCPOSAX(SCX)) Q:'SCTP  S SCPOSA(SCTP)=""
    49         .S:$D(@SCTEAMA@("EXCLUDE")) SCPOSA("EXCLUDE")=""
    50         ;S SCX=0 F  S SCX=$O(^DPT(DFN,"DE",SCX)) Q:'SCX  D
    51         ;.S SC44=+$G(^DPT(DFN,"DE",SCX,0))
    52         ;.Q:'SC44
    53         ;.Q:'$$OKCLIN(SC44,.SCPOSA)
    54         ;.S SCCLNM=$P($G(^SC(SC44,0)),U,1)
    55         ;.S SCS=0 F  S SCS=$O(^DPT(DFN,"DE",SCX,1,SCS)) Q:'SCS  D
    56         ;..S SCND=$G(^DPT(DFN,"DE",SCX,1,SCS,0))
    57         ;..S SCACT=$P(SCND,U,1)
    58         ;..S SCINACT=$P(SCND,U,3)
    59         ;..Q:'$$DTCHK^SCAPU1(SCBEGIN,SCEND,SCINCL,SCACT,SCINACT)
    60         ;..S SCACOPT=$P(SCND,U,2)
    61         ;..S SCREVDT=$P(SCND,U,5)
    62         ;..S SCN=$G(@SCLIST@(0),0)+1
    63         ;..;bp/ar nois brx-1298-12323 prevent undefined variable error
    64         ;..;New code begins
    65         ;..Q:'SCACT
    66         ;..Q:'SCN
    67         ;.;End of brx-1298-12323
    68         ;..S @SCLIST@(0)=SCN
    69         ;..S @SCLIST@(SCN)=SC44_U_SCCLNM_U_SCACT_U_SCINACT_U_SCACOPT_U_SCREVDT
    70         ;..S @SCLIST@("SCCL",SC44,SCACT,SCN)=""
    71 PTCLQ   Q $G(@SCERR@(0))<1
    72         ;
    73 OKCLIN(SC44,SCPOSA)     ;is clinic ok, given position array
    74         N SCOK,SCTP
    75         IF '$D(SCPOSA) S SCOK=1 G QTOKC
    76         S (SCOK,SCTP)=0
    77         F  S SCTP=$O(^SCTM(404.57,"E",+SC44,SCTP)) Q:'SCTP  S:$$OKARRAY^SCAPU1(.SCPOSA,SCTP) SCOK=1
    78 QTOKC   Q SCOK
    79         ;
    80 OKDATA()        ;check/setup variables - return 1 if ok; 0 if error
    81         N SCOK
    82         S SCOK=1
    83         D INIT^SCAPMCU1(.SCOK) ; set default dates & error array (if undefined)
    84         IF '$D(^DPT(+$G(DFN),0)) D  S SCOK=0
    85         . S SCPARM("PATIENT")=$G(DFN,"Undefined")
    86         . D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
    87         Q SCOK
     1SCAPMC29 ;ALB/REW - TEAM APIs:CLPT  ; 2/17/00 1:33pm
     2 ;;5.3;Scheduling;**41,210**;AUG 13, 1993
     3 ;;1.0
     4CLPT(DFN,SCDATES,SCTEAMA,SCLIST,SCERR) ;clinics for patient
     5 ; input:
     6 ;  DFN = ien of PATIENT <FILE#2> [required]
     7 ;  SCDATES("BEGIN") = begin date to search (inclusive)
     8 ;                       [default: TODAY]
     9 ;         ("END")   = end date to search (inclusive)
     10 ;                       [default: TODAY]
     11 ;         ("INCL")  = 1: only use pracitioners who were on
     12 ;                       team for entire date range
     13 ;                     0: anytime in date range
     14 ;                      [default: 1]
     15 ;  SCTEAMA= array of teams to include reverse with scposa('exclude')
     16 ;  SCERR = array NAME to store error messages.
     17 ;          [ex. ^TMP("ORXX",$J)]
     18 ;
     19 ; Output:
     20 ;  SCLIST() = array of clinics
     21 ;             Format:
     22 ;               Subscript: Sequential # from 1 to n
     23 ;               Piece     Description
     24 ;                 1       IEN of HOSPITAL LOCATION file entry (#44)
     25 ;                 2       Name of CLINIC
     26 ;                 3       ENROLLMENT DATE
     27 ;                 4       DISCHARGE DATE
     28 ;                 5       OPT OR AC
     29 ;                 6       REVIEW DATE
     30 ;
     31 ;  SCERR()  = Array of DIALOG file messages(errors) .
     32 ;  @SCERR(0)= Number of error(s), UNDEFINED if no errors
     33 ;             Foramt:
     34 ;               Subscript: Sequential # from 1 to n
     35 ;               Piece     Description
     36 ;                 1       IEN of DIALOG file
     37 ;   Returned: 1 if ok, 0 if error
     38 ;
     39 ; -- initialize control variables
     40 ;
     41ST N SCX,SCS,SC44,SCACOPT,SCTM,SCPOSA,SCTP
     42 N SCLSEQ,SCN,SCESEQ,SCPARM,SCP,SCBEGIN,SCEND,SCINCL,SCDTS,SCOK,SCS,SCND,SCACT,SCINACT,SCREVDT,SCCLNM
     43 G:'$$OKDATA PTCLQ ; check/setup variables
     44 IF $L($G(SCTEAMA)) D
     45 .S SCTM=0
     46 .F  S SCTM=$O(@SCTEAMA@(SCTM)) Q:'SCTM  D  Q:'SCX
     47 ..S SCX=$$TPTM^SCAPMC(SCTM,SCDATES,,,"SCPOSAX",.SCERR)
     48 .F SCX=1:1 S SCTP=+$G(SCPOSAX(SCX)) Q:'SCTP  S SCPOSA(SCTP)=""
     49 .S:$D(@SCTEAMA@("EXCLUDE")) SCPOSA("EXCLUDE")=""
     50 S SCX=0 F  S SCX=$O(^DPT(DFN,"DE",SCX)) Q:'SCX  D
     51 .S SC44=+$G(^DPT(DFN,"DE",SCX,0))
     52 .Q:'SC44
     53 .Q:'$$OKCLIN(SC44,.SCPOSA)
     54 .S SCCLNM=$P($G(^SC(SC44,0)),U,1)
     55 .S SCS=0 F  S SCS=$O(^DPT(DFN,"DE",SCX,1,SCS)) Q:'SCS  D
     56 ..S SCND=$G(^DPT(DFN,"DE",SCX,1,SCS,0))
     57 ..S SCACT=$P(SCND,U,1)
     58 ..S SCINACT=$P(SCND,U,3)
     59 ..Q:'$$DTCHK^SCAPU1(SCBEGIN,SCEND,SCINCL,SCACT,SCINACT)
     60 ..S SCACOPT=$P(SCND,U,2)
     61 ..S SCREVDT=$P(SCND,U,5)
     62 ..S SCN=$G(@SCLIST@(0),0)+1
     63 ..;bp/ar nois brx-1298-12323 prevent undefined variable error
     64 ..;New code begins
     65 ..Q:'SCACT
     66 ..Q:'SCN
     67 ..;End of brx-1298-12323
     68 ..S @SCLIST@(0)=SCN
     69 ..S @SCLIST@(SCN)=SC44_U_SCCLNM_U_SCACT_U_SCINACT_U_SCACOPT_U_SCREVDT
     70 ..S @SCLIST@("SCCL",SC44,SCACT,SCN)=""
     71PTCLQ Q $G(@SCERR@(0))<1
     72 ;
     73OKCLIN(SC44,SCPOSA) ;is clinic ok, given position array
     74 N SCOK,SCTP
     75 IF '$D(SCPOSA) S SCOK=1 G QTOKC
     76 S (SCOK,SCTP)=0
     77 F  S SCTP=$O(^SCTM(404.57,"D",+SC44,SCTP)) Q:'SCTP  S:$$OKARRAY^SCAPU1(.SCPOSA,SCTP) SCOK=1
     78QTOKC Q SCOK
     79 ;
     80OKDATA() ;check/setup variables - return 1 if ok; 0 if error
     81 N SCOK
     82 S SCOK=1
     83 D INIT^SCAPMCU1(.SCOK) ; set default dates & error array (if undefined)
     84 IF '$D(^DPT(+$G(DFN),0)) D  S SCOK=0
     85 . S SCPARM("PATIENT")=$G(DFN,"Undefined")
     86 . D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
     87 Q SCOK

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCAPMC30.m

    r613 r623  
    1 SCAPMC30        ;ALB/REW - TEAM APIs:TPCL  ; 30 Jun 95
    2         ;;5.3;Scheduling;**41,520**;AUG 13, 1993;Build 26
    3         ;;1.0
    4 TPCL(SC44,SCDATES,SCPOSA,SCUSRA,SCPURPA,SCROLEA,SCLIST,SCERR)   ;  -- list of positions for a clinic
    5         ; input:
    6         ;  SC44 = ien of HOSPITAL LOCATION <FILE#44> [required]
    7         ; SCDATES("BEGIN") = begin date to search (inclusive)
    8         ;                      [default: TODAY]
    9         ;        ("END")   = end date to search (inclusive)
    10         ;                      [default: TODAY]
    11         ;        ("INCL")  = 1: only use patients who were assigned to
    12         ;                       team for entire date range
    13         ;                    0: anytime in date range
    14         ;                      [default: 1]
    15         ;  SCPOSA -array of pointers to team position - 404.57 (per SCPURPA)
    16         ;  SCUSRA -array of pointers to user file - 8930 (per SCPURPA array)
    17         ;  SCPURPA -array of pointers to team purpose file 403.47
    18         ;          if none are defined - returns all teams
    19         ;          if @SCPURPA@('exclude') is defined - exclude listed teams
    20         ;  SCROLEA - array of pointers to std position file 403.46 (per SCPURPA)
    21         ;  SCLIST -array name to store list
    22         ;          [ex. ^TMP("SCPT",$J)]
    23         ;       
    24         ;  SCERR = array NAME to store error messages.
    25         ;          [ex. ^TMP("ORXX",$J)]
    26         ;
    27         ; Output:
    28         ;  SCLIST() = array of positions (includes SCTP xref)
    29         ;             Format:
    30         ;               Subscript: Sequential # from 1 to n
    31         ;               Piece     Description
    32         ;                 1       IEN of TEAM POSITION File (#404.57)
    33         ;                 2       Name of Position
    34         ;                 3       IEN of Team #404.51
    35         ;                 4       IEN of file #404.59 (Tm Pos History)
    36         ;                 5       current effective date
    37         ;                 6       current inactivate date (if any)
    38         ;                 7       pointer to 403.46 (role)
    39         ;                 8       Name of Standard Role
    40         ;                 9       pointer to User Class (#8930)
    41         ;                10       Name of User Class
    42         ;                Subscript: "SCTP",SCTM,IEN =""
    43         ;
    44         ;  SCERR() = Array of DIALOG file messages(errors) .
    45         ;  @SCERR@(0) = number of errors, undefined if none
    46         ;             Format:
    47         ;               Subscript: Sequential # from 1 to n
    48         ;               Piece     Description
    49         ;                 1       IEN of DIALOG file
    50         ;  Returned: 1 if ok, 0 if error
    51         ; Other:
    52         ;  SCACTHIS =  status (-1:err|0:inact|1:act)^404.52 ien ^actdt^inacdt
    53         ;
    54         ;
    55 ST      N SCPTTP,SCPTTP0,SCTP,SCR,SCACTHIS,SCTM,SCND,SCU,SCOK,SCP,SCTPCL
    56         N SCLSEQ,SCN,SCESEQ,SCPARM,SCBEGIN,SCEND,SCINCL,SCDTS
    57         ; -- initialize control variables
    58         S SCOK=1
    59         G:'$$OKDATA CLTPQ
    60         S SCTP=0 F  S SCTP=$O(^SCTM(404.57,"E",SC44,SCTP)) Q:'SCTP  D  Q:'SCOK
    61         .S SCTP0=$G(^SCTM(404.57,SCTP,0))
    62         .IF '$L(SCTP0) D
    63         ..S SCPARM("POSITION")=$G(SCTP,"Undefined")
    64         ..S SCPARM("CLINIC")=$G(SC44,"Undefined")
    65         ..D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
    66         .S SCTM=$P($G(^SCTM(404.57,SCTP,0)),U,2)
    67         .S SCP=$P(^SCTM(404.51,+SCTM,0),U,3)
    68         .Q:'$$OKARRAY^SCAPU1(.SCPURPA,.SCP)
    69         .S SCR=+$P(^SCTM(404.57,SCTP,0),U,3)
    70         .Q:'$$OKARRAY^SCAPU1(.SCROLEA,.SCR)
    71         .S SCACTHIS=$$ACTHIST^SCAPMCU2(404.59,SCTP,SCDATES,SCERR,"SCTPCL")
    72         .Q:'SCACTHIS
    73         .D BLD^SCAPMC24(.SCLIST,SCTM,SCTP,SCACTHIS,SCR)
    74 CLTPQ   Q $G(@SCERR@(0))<1
    75         ;
    76 OKDATA()        ;check/setup variables - return 1 if ok; 0 if error
    77         N SCOK
    78         S SCOK=1
    79         D INIT^SCAPMCU1(.SCOK) ; set default dates & error array (if undefined)
    80         IF '$D(^SC(+$G(SC44),0)) D  S SCOK=0
    81         . S SCPARM("CLINIC")=$G(SC44,"Undefined")
    82         . D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
    83         Q SCOK
     1SCAPMC30 ;ALB/REW - TEAM APIs:TPCL  ; 30 Jun 95
     2 ;;5.3;Scheduling;**41**;AUG 13, 1993
     3 ;;1.0
     4TPCL(SC44,SCDATES,SCPOSA,SCUSRA,SCPURPA,SCROLEA,SCLIST,SCERR) ;  -- list of positions for a clinic
     5 ; input:
     6 ;  SC44 = ien of HOSPITAL LOCATION <FILE#44> [required]
     7 ; SCDATES("BEGIN") = begin date to search (inclusive)
     8 ;                      [default: TODAY]
     9 ;        ("END")   = end date to search (inclusive)
     10 ;                      [default: TODAY]
     11 ;        ("INCL")  = 1: only use patients who were assigned to
     12 ;                       team for entire date range
     13 ;                    0: anytime in date range
     14 ;                      [default: 1]
     15 ;  SCPOSA -array of pointers to team position - 404.57 (per SCPURPA)
     16 ;  SCUSRA -array of pointers to user file - 8930 (per SCPURPA array)
     17 ;  SCPURPA -array of pointers to team purpose file 403.47
     18 ;          if none are defined - returns all teams
     19 ;          if @SCPURPA@('exclude') is defined - exclude listed teams
     20 ;  SCROLEA - array of pointers to std position file 403.46 (per SCPURPA)
     21 ;  SCLIST -array name to store list
     22 ;          [ex. ^TMP("SCPT",$J)]
     23 ;       
     24 ;  SCERR = array NAME to store error messages.
     25 ;          [ex. ^TMP("ORXX",$J)]
     26 ;
     27 ; Output:
     28 ;  SCLIST() = array of positions (includes SCTP xref)
     29 ;             Format:
     30 ;               Subscript: Sequential # from 1 to n
     31 ;               Piece     Description
     32 ;                 1       IEN of TEAM POSITION File (#404.57)
     33 ;                 2       Name of Position
     34 ;                 3       IEN of Team #404.51
     35 ;                 4       IEN of file #404.59 (Tm Pos History)
     36 ;                 5       current effective date
     37 ;                 6       current inactivate date (if any)
     38 ;                 7       pointer to 403.46 (role)
     39 ;                 8       Name of Standard Role
     40 ;                 9       pointer to User Class (#8930)
     41 ;                10       Name of User Class
     42 ;                Subscript: "SCTP",SCTM,IEN =""
     43 ;
     44 ;  SCERR() = Array of DIALOG file messages(errors) .
     45 ;  @SCERR@(0) = number of errors, undefined if none
     46 ;             Format:
     47 ;               Subscript: Sequential # from 1 to n
     48 ;               Piece     Description
     49 ;                 1       IEN of DIALOG file
     50 ;  Returned: 1 if ok, 0 if error
     51 ; Other:
     52 ;  SCACTHIS =  status (-1:err|0:inact|1:act)^404.52 ien ^actdt^inacdt
     53 ;
     54 ;
     55ST N SCPTTP,SCPTTP0,SCTP,SCR,SCACTHIS,SCTM,SCND,SCU,SCOK,SCP,SCTPCL
     56 N SCLSEQ,SCN,SCESEQ,SCPARM,SCBEGIN,SCEND,SCINCL,SCDTS
     57 ; -- initialize control variables
     58 S SCOK=1
     59 G:'$$OKDATA CLTPQ
     60 S SCTP=0 F  S SCTP=$O(^SCTM(404.57,"D",SC44,SCTP)) Q:'SCTP  D  Q:'SCOK
     61 .S SCTP0=$G(^SCTM(404.57,SCTP,0))
     62 .IF '$L(SCTP0) D
     63 ..S SCPARM("POSITION")=$G(SCTP,"Undefined")
     64 ..S SCPARM("CLINIC")=$G(SC44,"Undefined")
     65 ..D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
     66 .S SCTM=$P($G(^SCTM(404.57,SCTP,0)),U,2)
     67 .S SCP=$P(^SCTM(404.51,+SCTM,0),U,3)
     68 .Q:'$$OKARRAY^SCAPU1(.SCPURPA,.SCP)
     69 .S SCR=+$P(^SCTM(404.57,SCTP,0),U,3)
     70 .Q:'$$OKARRAY^SCAPU1(.SCROLEA,.SCR)
     71 .S SCACTHIS=$$ACTHIST^SCAPMCU2(404.59,SCTP,SCDATES,SCERR,"SCTPCL")
     72 .Q:'SCACTHIS
     73 .D BLD^SCAPMC24(.SCLIST,SCTM,SCTP,SCACTHIS,SCR)
     74CLTPQ Q $G(@SCERR@(0))<1
     75 ;
     76OKDATA() ;check/setup variables - return 1 if ok; 0 if error
     77 N SCOK
     78 S SCOK=1
     79 D INIT^SCAPMCU1(.SCOK) ; set default dates & error array (if undefined)
     80 IF '$D(^SC(+$G(SC44),0)) D  S SCOK=0
     81 . S SCPARM("CLINIC")=$G(SC44,"Undefined")
     82 . D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
     83 Q SCOK

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCAPMC9.m

    r613 r623  
    1 SCAPMC9 ;ALB/REW - Team API's:PRCL ; JUN 26, 1995
    2         ;;5.3;Scheduling;**41,112,520**;AUG 13, 1993;Build 26
    3         ;;1.0
    4 PRCL(SC44,SCDATES,SCPOSA,SCUSRA,SCROLEA,SCLIST,SCERR)   ;-- list of practitioners for clinic
    5         ; input:
    6         ;  SC44 = ien of CLINIC <FILE#44> [required]
    7         ;  SCDATES("BEGIN") = begin date to search (inclusive)
    8         ;                       [default: TODAY]
    9         ;         ("END")   = end date to search (inclusive)
    10         ;                       [default: TODAY]
    11         ;         ("INCL")  = 1: only use pracitioners who were on
    12         ;                       team for entire date range
    13         ;                     0: anytime in date range
    14         ;                      [default: 1]
    15         ;  SCPOSA= array of positions to include reverse with scposa('exclude')
    16         ;  SCUSRA= array of usr classes included reverse with scusra('exclude')
    17         ;  SCROLEA= array of roles included reverse with SCROLEA('exclude')
    18         ;  SCERR = array NAME to store error messages.
    19         ;          [ex. ^TMP("ORXX",$J)]
    20         ;
    21         ; Output:
    22         ;  SCLIST() = array of practitioners
    23         ;             Format:
    24         ;               Subscript: Sequential # from 1 to n
    25         ;               Piece     Description
    26         ;                 1       IEN of NEW PERSON file entry (#200)
    27         ;                 2       Name of person
    28         ;                 3       IEN of TEAM POSITION file (#404.57)
    29         ;                 4       Name of Position
    30         ;                 5       IEN OF USR CLASS(#8930) of POSITION (#404.57)
    31         ;                 6       USR Class Name
    32         ;                 7       IEN of STANDARD POSITION (#403.46)
    33         ;                 8       Standard Role (Position) Name
    34         ;                 9       Activation Date for 404.52 (not 404.59!)
    35         ;                 10      Inactivation Date for 404.52
    36         ;                 11      IEN of Position Ass History (404.52)
    37         ;                 12      IEN of Preceptor Position
    38         ;                 13      Name of Preceptor Position
    39         ;  @sclist@('scpr',sc200,sctp,scact,scn)=""
    40         ;
    41         ;  SCERR() = Array of DIALOG file messages(errors) .
    42         ;             Foramt:
    43         ;  @SCERR@(0) = Number of errors, undefined if none
    44         ;               Subscript: Sequential # from 1 to n
    45         ;               Piece     Description
    46         ;                 1       IEN of DIALOG file
    47         ;   Returned: 1 if ok, 0 if error
    48         ;
    49         ;
    50 ST      N SCPOSNM,SCTP,SCPOS0,SCOK,SCND,SCU,SCR,SCPRCL
    51         N SCLSEQ,SCN,SCESEQ,SCPARM,SCP,SCBEGIN,SCEND,SCINCL,SCDTS
    52         ; -- initialize control variables
    53         G:'$$OKDATA PRACQ ; check/setup variables
    54         ; -- loop through team positions
    55         S SCTP=0
    56         F  S SCTP=$O(^SCTM(404.57,"E",SC44,SCTP)) Q:SCTP=""  D
    57         .Q:'$$OKARRAY^SCAPU1(.SCPOSA,SCTP)
    58         .S SCND=$G(^SCTM(404.57,SCTP,0))
    59         .S SCU=$P(SCND,U,13)
    60         .Q:'$$OKUSRCL^SCAPU1(.SCUSRA,SCU)
    61         .S SCR=$P(SCND,U,3)
    62         .Q:'$$OKARRAY^SCAPU1(.SCROLEA,.SCR)
    63         .IF 'SCTP D  Q
    64         ..S SCPARM("Position")=$G(SCTP,"Undefined")
    65         ..D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",SCERR)
    66         .ELSE  D
    67         ..S SCX=$$ACTHIST^SCAPMCU2(404.52,SCTP,SCDATES,.SCERR,"SCPRCL")
    68         ..S:SCX X=$$PRTP^SCAPMC8(SCTP,SCDATES,.SCLIST,.SCERR)
    69 PRACQ   Q $G(@SCERR@(0))<1
    70 OKDATA()        ;check/setup variables - return 1 if ok/ 0 if error
    71         N SCOK
    72         S SCOK=1
    73         D INIT^SCAPMCU1(.SCOK) ; set default dates & error array (if undefined)
    74         ;
    75         IF '$D(^SC(+$G(SC44),0)) D  S SCOK=0
    76         . S SCPARM("CLINIC")=$G(SC44,"Undefined")
    77         . D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
    78         Q SCOK
     1SCAPMC9 ;ALB/REW - Team API's:PRCL ; JUN 26, 1995
     2 ;;5.3;Scheduling;**41,112**;AUG 13, 1993
     3 ;;1.0
     4PRCL(SC44,SCDATES,SCPOSA,SCUSRA,SCROLEA,SCLIST,SCERR) ;-- list of practitioners for clinic
     5 ; input:
     6 ;  SC44 = ien of CLINIC <FILE#44> [required]
     7 ;  SCDATES("BEGIN") = begin date to search (inclusive)
     8 ;                       [default: TODAY]
     9 ;         ("END")   = end date to search (inclusive)
     10 ;                       [default: TODAY]
     11 ;         ("INCL")  = 1: only use pracitioners who were on
     12 ;                       team for entire date range
     13 ;                     0: anytime in date range
     14 ;                      [default: 1]
     15 ;  SCPOSA= array of positions to include reverse with scposa('exclude')
     16 ;  SCUSRA= array of usr classes included reverse with scusra('exclude')
     17 ;  SCROLEA= array of roles included reverse with SCROLEA('exclude')
     18 ;  SCERR = array NAME to store error messages.
     19 ;          [ex. ^TMP("ORXX",$J)]
     20 ;
     21 ; Output:
     22 ;  SCLIST() = array of practitioners
     23 ;             Format:
     24 ;               Subscript: Sequential # from 1 to n
     25 ;               Piece     Description
     26 ;                 1       IEN of NEW PERSON file entry (#200)
     27 ;                 2       Name of person
     28 ;                 3       IEN of TEAM POSITION file (#404.57)
     29 ;                 4       Name of Position
     30 ;                 5       IEN OF USR CLASS(#8930) of POSITION (#404.57)
     31 ;                 6       USR Class Name
     32 ;                 7       IEN of STANDARD POSITION (#403.46)
     33 ;                 8       Standard Role (Position) Name
     34 ;                 9       Activation Date for 404.52 (not 404.59!)
     35 ;                 10      Inactivation Date for 404.52
     36 ;                 11      IEN of Position Ass History (404.52)
     37 ;                 12      IEN of Preceptor Position
     38 ;                 13      Name of Preceptor Position
     39 ;  @sclist@('scpr',sc200,sctp,scact,scn)=""
     40 ;
     41 ;  SCERR() = Array of DIALOG file messages(errors) .
     42 ;             Foramt:
     43 ;  @SCERR@(0) = Number of errors, undefined if none
     44 ;               Subscript: Sequential # from 1 to n
     45 ;               Piece     Description
     46 ;                 1       IEN of DIALOG file
     47 ;   Returned: 1 if ok, 0 if error
     48 ;
     49 ;
     50ST N SCPOSNM,SCTP,SCPOS0,SCOK,SCND,SCU,SCR,SCPRCL
     51 N SCLSEQ,SCN,SCESEQ,SCPARM,SCP,SCBEGIN,SCEND,SCINCL,SCDTS
     52 ; -- initialize control variables
     53 G:'$$OKDATA PRACQ ; check/setup variables
     54 ; -- loop through team positions
     55 S SCTP=0
     56 F  S SCTP=$O(^SCTM(404.57,"D",SC44,SCTP)) Q:SCTP=""  D
     57 .Q:'$$OKARRAY^SCAPU1(.SCPOSA,SCTP)
     58 .S SCND=$G(^SCTM(404.57,SCTP,0))
     59 .S SCU=$P(SCND,U,13)
     60 .Q:'$$OKUSRCL^SCAPU1(.SCUSRA,SCU)
     61 .S SCR=$P(SCND,U,3)
     62 .Q:'$$OKARRAY^SCAPU1(.SCROLEA,.SCR)
     63 .IF 'SCTP D  Q
     64 ..S SCPARM("Position")=$G(SCTP,"Undefined")
     65 ..D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",SCERR)
     66 .ELSE  D
     67 ..S SCX=$$ACTHIST^SCAPMCU2(404.52,SCTP,SCDATES,.SCERR,"SCPRCL")
     68 ..S:SCX X=$$PRTP^SCAPMC8(SCTP,SCDATES,.SCLIST,.SCERR)
     69PRACQ Q $G(@SCERR@(0))<1
     70OKDATA() ;check/setup variables - return 1 if ok/ 0 if error
     71 N SCOK
     72 S SCOK=1
     73 D INIT^SCAPMCU1(.SCOK) ; set default dates & error array (if undefined)
     74 ;
     75 IF '$D(^SC(+$G(SC44),0)) D  S SCOK=0
     76 . S SCPARM("CLINIC")=$G(SC44,"Undefined")
     77 . D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
     78 Q SCOK

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCAPMCU2.m

    r613 r623  
    1 SCAPMCU2        ;ALB/REW - TEAM API UTILITIES ;6/29/99  19:40  ; Compiled May 29, 2007 15:16:13
    2         ;;5.3;Scheduling;**41,177,205,458**;AUG 13, 1993;Build 14
    3         ;;1.0
    4 DTAFTER(FILE,IEN,STATUS,DATE)   ;return next date after given one
    5         N SCX
    6         S SCX=-1
    7         G:('$G(FILE))!("^404.52^404.58^404.59^"'[$G(FILE))!('$G(IEN)) QTDTAF
    8         S ROOT="^SCTM("_FILE_",""AIDT"",IEN,STATUS)"
    9         S EFFDT=-DATE
    10         S SCX=$P($O(@ROOT@(EFFDT),-1),"-",2)
    11 QTDTAF  Q SCX
    12         ;
    13 DTBEFORE(FILE,IEN,STATUS,DATE)  ;return next date before given one
    14         N SCX
    15         S SCX=-1
    16         G:('$G(FILE))!("^404.52^404.58^404.59^"'[$G(FILE))!('$G(IEN)) QTDTBF
    17         S ROOT="^SCTM("_FILE_",""AIDT"",IEN,STATUS)"
    18         S EFFDT=-DATE
    19         S SCX=$P($O(@ROOT@(EFFDT)),"-",2)
    20 QTDTBF  Q SCX
    21         ;
    22 ACTHISTB(FILE,IEN)      ;boolean active function
    23         ;abbreviated form of call below - no error handling
    24         N X,SCACTB
    25         S X=+$$ACTHIST(.FILE,.IEN,"SCACTB")
    26         Q $S(X=1:1,1:0)
    27         ;
    28 ACTHIST(FILE,IEN,SCDATES,SCERR,SCLIST)  ;is entry active for a time period?
    29         ; Input Parameters:
    30         ;    File = either 404.52 or 404.58 or 404.59
    31         ;    IEN  = pointer to team(404.51) or team position(404.57)
    32         ;    SCDATES = (SEE PRIOR DEFINITION)
    33         ;    SCLIST  = Output array
    34         ;  Returned:
    35         ;  status (-1:error|0:inactive|1:active)^ien for file^actdt^inacdt
    36         ;          which ien depends on status
    37         ;
    38         N OK,X,ROOT,SCBEGIN,SCEND,SCINCL,SCDATE,SCA,SCDTS,SCE
    39         S OK=-1,X=""
    40         G:('$G(FILE))!("^404.52^404.53^404.58^404.59^"'[$G(FILE))!('$G(IEN)) QTACTH
    41         S ROOT="^SCTM("_FILE_",""AIDT"",IEN,SCSTAT"
    42         D INIT^SCAPMCU1(.OK) ; set default dates,output & error array (if undefined)
    43         IF 'OK S OK=-1 G QTACTH
    44         S SCDATE=SCEND
    45         S OK=0
    46         ;if incl=0 ->a partial hit should be returned
    47 LOOP    IF 'SCINCL D
    48         .F  S X=$$DATES^SCAPMCU1(.FILE,.IEN,.SCDATE) S SCA=$P(X,U,2),SCE=$P(X,U,3) D  Q:$P(X,U,5)!(SCE<SCBEGIN)!(OK=-1)
    49         ..IF 'X S SCDATE=SCA Q
    50         ..IF +X=1 D
    51         ...S OK=1
    52         ...S SCDATE=SCA-.000001
    53         ...Q:$D(@SCLIST@(FILE,"SCLST",IEN,SCA))
    54         ...S SCN=$G(@SCLIST@(FILE,0),0)+1
    55         ...S @SCLIST@(FILE,0)=SCN
    56         ...S @SCLIST@(FILE,SCN)=IEN_U_$$EXT(FILE,IEN)_U_SCA_U_$P(X,U,3)
    57         ...S @SCLIST@(FILE,"SCLST",IEN,SCA,SCN)=""
    58         ..ELSE  D
    59         ...S OK=-1
    60         ...S SCPARM("EFFECTIVE DATE")=$G(SCDATE,"Undefined")
    61         ...D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
    62         ELSE  D
    63         .S X=$$DATES^SCAPMCU1(.FILE,.IEN,.SCDATE)
    64         .IF X&($P(X,U,2)'>SCBEGIN) D
    65         ..S OK=1
    66         ..Q:$D(@SCLIST@(FILE,"SCLST",IEN,$P(X,U,2)))
    67         ..S SCN=$G(@SCLIST@(FILE,0),0)+1
    68         ..S @SCLIST@(FILE,0)=SCN
    69         ..S @SCLIST@(FILE,SCN)=IEN_U_$$EXT(FILE,IEN)_U_$P(X,U,2)_U_$P(X,U,3)
    70         ..S @SCLIST@(FILE,"SCLST",IEN,$P(X,U,2),SCN)=""
    71 QTACTH  Q OK_U_$P(X,U,4)_U_$P(X,U,2)_U_$P(X,U,3)
    72         ;
    73 EXT(FILE,IEN)   ;return external value of team or team position file
    74         N SCEXT
    75         S SCEXT=-1
    76         IF FILE=404.58 D
    77         .S SCEXT=$P($G(^SCTM(404.51,+$G(IEN),0)),U,1)
    78         .S:'$L(SCEXT) SCEXT=-1
    79         IF "^404.52^404.53^404.59^"[(U_FILE_U) D
    80         .S SCEXT=$P($G(^SCTM(404.57,+$G(IEN),0)),U,1)
    81         .S:'$L(SCEXT) SCEXT=-1
    82 QTEXT   Q SCEXT
    83         ;
    84 GETPC(DFN,DATE,PCROLE,ASSTYPE)  ;return pc position & team for a date
    85         ; DFN - pointer to patient file
    86         ; DATE - date of interest (Default=DT)
    87         ; PCROLE - Default=1 (PC Practitioner Position) note 2= pc attending
    88         ; ASSTYPE - Default=1 (PC Team)
    89         ; returns sctp^sctm^assigned to pc?
    90         ;
    91         N ACTDT,SCTP,SCTM,SCPTA,INACTDT
    92         Q $$GETPCTP(.DFN,.DATE,.PCROLE)_U_$$GETPCTM(.DFN,.DATE,.ASSTYPE)_U_($D(^SCPT(404.41,"APC",+DFN))>0)
    93         ;
    94 HISTPTTP(DFN,SCTP,DATE) ;404.43 entry for pt,position - if active on date
    95         ;return -1 if error, 0 if no active entry or 404.43 ien if one
    96         Q:'$G(DFN)!('$G(SCTP))!('$G(DATE)) -1
    97         N SCACT,HISTIEN,SCINACT,SCDT
    98         S SCDT=DATE+.00000001
    99         S SCACT=+$O(^SCPT(404.43,"ADFN",DFN,SCTP,SCDT),-1)
    100         S HISTIEN=+$O(^SCPT(404.43,"ADFN",DFN,SCTP,SCACT,0))
    101         S SCINACT=$P($G(^SCPT(404.43,HISTIEN,0)),U,4)
    102         Q $S('SCACT:0,('HISTIEN):0,('SCINACT):HISTIEN,(DATE>SCINACT):0,1:HISTIEN)
    103         ;
    104 HISTPTTM(DFN,SCTM,DATE) ;404.42 entry for tm,position - if active on date
    105         ; return -1 if error, 0 if no active entry or 404.42 entyr if one
    106         Q:'$G(DFN)!('$G(SCTM))!('$G(DATE)) -1
    107         N SCACT,HISTIEN,SCINACT,SCDT
    108         S SCDT=DATE+.00000001
    109         S SCACT=-$O(^SCPT(404.42,"AIDT",DFN,SCTM,-SCDT))
    110         S HISTIEN=+$O(^SCPT(404.42,"AIDT",DFN,SCTM,-SCACT,0))
    111         S SCINACT=$P($G(^SCPT(404.42,HISTIEN,0)),U,9)
    112         Q $S('SCACT:0,('HISTIEN):0,('SCINACT):HISTIEN,(DATE>SCINACT):0,1:HISTIEN)
    113         ;
    114 GETPCTM(DFN,DATE,ASSTYPE)       ;return pc team for a date
    115         ; DFN - pointer to patient file
    116         ; DATE - date of interest
    117         ; ASSTYPE - Default=1 (PC Team)
    118         ; returns sctm
    119         ;
    120         N ACTDT,SCTP,SCPTTMA,SCINDT,SCTM,SCGOOD
    121         S ASSTYPE=$G(ASSTYPE,1)
    122         S DATE=$G(DATE,DT)
    123         ; returns pointer to 404.51, if exists, 0 if not
    124         S ACTDT=+$O(^SCPT(404.42,"APCTM",+DFN,+ASSTYPE,(DATE+.000001)),-1)
    125         I 'ACTDT Q 0
    126         S SCTM=0,SCGOOD=0
    127         F  S SCTM=$O(^SCPT(404.42,"APCTM",+DFN,+ASSTYPE,+ACTDT,SCTM)) Q:SCTM=""  D  Q:SCGOOD
    128         .S SCPTTMA=$O(^SCPT(404.42,"APCTM",+DFN,+ASSTYPE,+ACTDT,+SCTM,""),-1)
    129         .S SCINDT=$P($G(^SCPT(404.42,+SCPTTMA,0)),U,9)
    130         .I SCINDT="" S SCGOOD=1 Q
    131         Q $S('SCINDT:+SCTM,(SCINDT'<DATE):+SCTM,1:0)
    132         ;
    133 GETPCTP(DFN,DATE,PCROLE)        ;return pc position for a date
    134         ; DFN - pointer to patient file
    135         ; DATE - date of interest
    136         ; PCROLE - Default=1 (PC Practitioner Position) note 2= pc attending
    137         ; returns sctp,or 0 if none or -1 if error
    138         ;
    139         N ACTDT,SCTP,SCTM,SCPTA,INACTDT,SCPTTPA,SCOK,TPLP,TPDALP
    140         S SCOK=1,SCTP=0
    141         S DATE=$G(DATE,DT)
    142         S PCROLE=$G(PCROLE,1)
    143         ; returns pointer to 404.57, if exists, 0 if not
    144         S ACTDT=+$O(^SCPT(404.43,"APCPOS",+DFN,+PCROLE,(DATE+.000001)),-1)
    145         F TPLP=0:0 S TPLP=$O(^SCPT(404.43,"APCPOS",+DFN,+PCROLE,+ACTDT,TPLP)) Q:TPLP=""!(SCTP=-1)  F TPDALP=0:0 S TPDALP=$O(^SCPT(404.43,"APCPOS",+DFN,+PCROLE,+ACTDT,TPLP,TPDALP)) Q:TPDALP=""  DO  Q:SCTP=-1
    146         .S INACTDT=$P($G(^SCPT(404.43,+TPDALP,0)),U,4)
    147         .;if already an active date then an error
    148         .I 'INACTDT S SCTP=$S(SCTP>0:-1,1:TPLP) Q
    149         .I INACTDT'<DATE S SCTP=$S(SCTP>0:-1,1:TPLP)
    150         .Q
    151         Q +SCTP
    152         ;
    153 GETPRTP(SCTP,DATE)      ;returns ien & name of practitioner filling position
    154         ;   Returned [Error:-1,Else: sc200^practname]
    155         N X,SCPRDTS,SCPR
    156         S DATE=$G(DATE,DT)
    157         S SCPRDTS("BEGIN")=DATE
    158         S SCPRDTS("END")=DATE
    159         S X=$$PRTP^SCAPMC(SCTP,"SCPRDTS","SCPR")
    160         Q $S(X<1:-1,1:$P($G(SCPR(1)),U,1)_U_$P($G(SCPR(1)),U,2))
    161         ;
    162 EXTMPRTP(SCTP,DATE)     ;returns external of team and practitioner for position
    163         ;
    164         N SCX
    165         S SCX=$$GETPRTP(.SCTP,.DATE)
    166         Q $P($G(^SCTM(404.51,+$P($G(^SCTM(404.57,+SCTP,0)),U,2),0)),U,1)_"   "_$P(SCX,U,2)
    167         ;
    168 NMPCTP(DFN,DATE,PCROLE) ;returns ien & name of pc position
    169         ; (See GETPCTP for variables)
    170         N X
    171         S X=$$GETPCTP(DFN,.DATE,.PCROLE)
    172         Q $S('$G(X):"",X=-1:"",1:X_U_$P($G(^SCTM(404.57,+X,0)),U,1))
    173         ;
    174 NMPCPR(DFN,DATE,PCROLE) ;returns ien & name of pract filling pc position
    175         ; DFN - pointer to patient file
    176         ; DATE - date of interest
    177         ; PCROLE - Practitioner Position where '1' = PC provider
    178         ;                                      '2' = PC attending
    179         ;                                      '3' = PC associate provider
    180         ;
    181         ; returns sctp (ien^name), or "" if none or -1 if error
    182         ;
    183         N SCTP,PCAP
    184         ;bp/cmf 205 original code next line
    185         ;S PCAP=PCROLE S:PCROLE=3 PCROLE=1
    186         ;bp/cmf 205 change code begin
    187         ;;S PCROLE=+$G(PCROLE,1),(PCAP,PCROLE)=$S(PCROLE=0:1,PCROLE>2:1,1:PCROLE)
    188         S (PCROLE,PCAP)=+$G(PCROLE,1)
    189         S PCAP=$S(PCAP=0:1,PCAP>3:1,1:PCAP)
    190         S PCROLE=$S(PCROLE=0:1,PCROLE>2:1,1:PCROLE)
    191         ;bp/cmf 205 change code end
    192         S SCTP=+$$NMPCTP(.DFN,.DATE,.PCROLE)
    193         Q $S('SCTP:"",1:$$PCPROV^SCAPMCU3(SCTP,.DATE,PCAP))
    194         ;
    195 NMPCTM(DFN,DATE,PCROLE) ;returns ien & name of pc team
    196         ; (See GETPCTM for variables)
    197         N X
    198         S X=$$GETPCTM(DFN,.DATE,.PCROLE)
    199         Q $S('$G(X):"",1:X_U_$P($G(^SCTM(404.51,+X,0)),U,1))
    200         ;
    201 ALPHA(INARRAY,OUTARRAY) ;not supported - for PCMM only
    202         ; returns array sorted by 2nd piece's value
    203         ; it keeps the 0 node -it does not return any x-ref values
    204         ; it only converts arrays of type 1-n to another 1-n array
    205         N SCNDX,SCX,SCNODE,SCY
    206         S (SCX,SCY)=0
    207         S:$D(@INARRAY@(0)) @OUTARRAY@(0)=@INARRAY@(0)
    208         F  S SCX=$O(@INARRAY@(SCX)) Q:'SCX  S SCNODE=@INARRAY@(SCX) Q:'$L(SCNODE)  D
    209         .S ^TMP($J,"SCTMPSORT","B",$P(SCNODE,U,2),SCX)=""
    210         S SCNDX=""
    211         F  S SCNDX=$O(^TMP($J,"SCTMPSORT","B",SCNDX)) Q:SCNDX=""  D
    212         .S SCX=0
    213         .F  S SCX=$O(^TMP($J,"SCTMPSORT","B",SCNDX,SCX)) Q:'SCX  D
    214         ..S SCY=SCY+1
    215         ..S @OUTARRAY@(SCY)=$G(@INARRAY@(SCX))
    216         K ^TMP($J,"SCTMPSORT","B")
    217         Q
     1SCAPMCU2 ;ALB/REW - TEAM API UTILITIES ;6/29/99  19:40
     2 ;;5.3;Scheduling;**41,177,205**;AUG 13, 1993
     3 ;;1.0
     4DTAFTER(FILE,IEN,STATUS,DATE) ;return next date after given one
     5 N SCX
     6 S SCX=-1
     7 G:('$G(FILE))!("^404.52^404.58^404.59^"'[$G(FILE))!('$G(IEN)) QTDTAF
     8 S ROOT="^SCTM("_FILE_",""AIDT"",IEN,STATUS)"
     9 S EFFDT=-DATE
     10 S SCX=$P($O(@ROOT@(EFFDT),-1),"-",2)
     11QTDTAF Q SCX
     12 ;
     13DTBEFORE(FILE,IEN,STATUS,DATE) ;return next date before given one
     14 N SCX
     15 S SCX=-1
     16 G:('$G(FILE))!("^404.52^404.58^404.59^"'[$G(FILE))!('$G(IEN)) QTDTBF
     17 S ROOT="^SCTM("_FILE_",""AIDT"",IEN,STATUS)"
     18 S EFFDT=-DATE
     19 S SCX=$P($O(@ROOT@(EFFDT)),"-",2)
     20QTDTBF Q SCX
     21 ;
     22ACTHISTB(FILE,IEN) ;boolean active function
     23 ;abbreviated form of call below - no error handling
     24 N X,SCACTB
     25 S X=+$$ACTHIST(.FILE,.IEN,"SCACTB")
     26 Q $S(X=1:1,1:0)
     27 ;
     28ACTHIST(FILE,IEN,SCDATES,SCERR,SCLIST) ;is entry active for a time period?
     29 ; Input Parameters:
     30 ;    File = either 404.52 or 404.58 or 404.59
     31 ;    IEN  = pointer to team(404.51) or team position(404.57)
     32 ;    SCDATES = (SEE PRIOR DEFINITION)
     33 ;    SCLIST  = Output array
     34 ;  Returned:
     35 ;  status (-1:error|0:inactive|1:active)^ien for file^actdt^inacdt
     36 ;          which ien depends on status
     37 ;
     38 N OK,X,ROOT,SCBEGIN,SCEND,SCINCL,SCDATE,SCA,SCDTS,SCE
     39 S OK=-1,X=""
     40 G:('$G(FILE))!("^404.52^404.53^404.58^404.59^"'[$G(FILE))!('$G(IEN)) QTACTH
     41 S ROOT="^SCTM("_FILE_",""AIDT"",IEN,SCSTAT"
     42 D INIT^SCAPMCU1(.OK) ; set default dates,output & error array (if undefined)
     43 IF 'OK S OK=-1 G QTACTH
     44 S SCDATE=SCEND
     45 S OK=0
     46 ;if incl=0 ->a partial hit should be returned
     47LOOP IF 'SCINCL D
     48 .F  S X=$$DATES^SCAPMCU1(.FILE,.IEN,.SCDATE) S SCA=$P(X,U,2),SCE=$P(X,U,3) D  Q:$P(X,U,5)!(SCE<SCBEGIN)!(OK=-1)
     49 ..IF 'X S SCDATE=SCA Q
     50 ..IF +X=1 D
     51 ...S OK=1
     52 ...S SCDATE=SCA-.000001
     53 ...Q:$D(@SCLIST@(FILE,"SCLST",IEN,SCA))
     54 ...S SCN=$G(@SCLIST@(FILE,0),0)+1
     55 ...S @SCLIST@(FILE,0)=SCN
     56 ...S @SCLIST@(FILE,SCN)=IEN_U_$$EXT(FILE,IEN)_U_SCA_U_$P(X,U,3)
     57 ...S @SCLIST@(FILE,"SCLST",IEN,SCA,SCN)=""
     58 ..ELSE  D
     59 ...S OK=-1
     60 ...S SCPARM("EFFECTIVE DATE")=$G(SCDATE,"Undefined")
     61 ...D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
     62 ELSE  D
     63 .S X=$$DATES^SCAPMCU1(.FILE,.IEN,.SCDATE)
     64 .IF X&($P(X,U,2)'>SCBEGIN) D
     65 ..S OK=1
     66 ..Q:$D(@SCLIST@(FILE,"SCLST",IEN,$P(X,U,2)))
     67 ..S SCN=$G(@SCLIST@(FILE,0),0)+1
     68 ..S @SCLIST@(FILE,0)=SCN
     69 ..S @SCLIST@(FILE,SCN)=IEN_U_$$EXT(FILE,IEN)_U_$P(X,U,2)_U_$P(X,U,3)
     70 ..S @SCLIST@(FILE,"SCLST",IEN,$P(X,U,2),SCN)=""
     71QTACTH Q OK_U_$P(X,U,4)_U_$P(X,U,2)_U_$P(X,U,3)
     72 ;
     73EXT(FILE,IEN) ;return external value of team or team position file
     74 N SCEXT
     75 S SCEXT=-1
     76 IF FILE=404.58 D
     77 .S SCEXT=$P($G(^SCTM(404.51,+$G(IEN),0)),U,1)
     78 .S:'$L(SCEXT) SCEXT=-1
     79 IF "^404.52^404.53^404.59^"[(U_FILE_U) D
     80 .S SCEXT=$P($G(^SCTM(404.57,+$G(IEN),0)),U,1)
     81 .S:'$L(SCEXT) SCEXT=-1
     82QTEXT Q SCEXT
     83 ;
     84GETPC(DFN,DATE,PCROLE,ASSTYPE) ;return pc position & team for a date
     85 ; DFN - pointer to patient file
     86 ; DATE - date of interest (Default=DT)
     87 ; PCROLE - Default=1 (PC Practitioner Position) note 2= pc attending
     88 ; ASSTYPE - Default=1 (PC Team)
     89 ; returns sctp^sctm^assigned to pc?
     90 ;
     91 N ACTDT,SCTP,SCTM,SCPTA,INACTDT
     92 Q $$GETPCTP(.DFN,.DATE,.PCROLE)_U_$$GETPCTM(.DFN,.DATE,.ASSTYPE)_U_($D(^SCPT(404.41,"APC",+DFN))>0)
     93 ;
     94HISTPTTP(DFN,SCTP,DATE) ;404.43 entry for pt,position - if active on date
     95 ;return -1 if error, 0 if no active entry or 404.43 ien if one
     96 Q:'$G(DFN)!('$G(SCTP))!('$G(DATE)) -1
     97 N SCACT,HISTIEN,SCINACT,SCDT
     98 S SCDT=DATE+.00000001
     99 S SCACT=+$O(^SCPT(404.43,"ADFN",DFN,SCTP,SCDT),-1)
     100 S HISTIEN=+$O(^SCPT(404.43,"ADFN",DFN,SCTP,SCACT,0))
     101 S SCINACT=$P($G(^SCPT(404.43,HISTIEN,0)),U,4)
     102 Q $S('SCACT:0,('HISTIEN):0,('SCINACT):HISTIEN,(DATE>SCINACT):0,1:HISTIEN)
     103 ;
     104HISTPTTM(DFN,SCTM,DATE) ;404.42 entry for tm,position - if active on date
     105 ; return -1 if error, 0 if no active entry or 404.42 entyr if one
     106 Q:'$G(DFN)!('$G(SCTM))!('$G(DATE)) -1
     107 N SCACT,HISTIEN,SCINACT,SCDT
     108 S SCDT=DATE+.00000001
     109 S SCACT=-$O(^SCPT(404.42,"AIDT",DFN,SCTM,-SCDT))
     110 S HISTIEN=+$O(^SCPT(404.42,"AIDT",DFN,SCTM,-SCACT,0))
     111 S SCINACT=$P($G(^SCPT(404.42,HISTIEN,0)),U,9)
     112 Q $S('SCACT:0,('HISTIEN):0,('SCINACT):HISTIEN,(DATE>SCINACT):0,1:HISTIEN)
     113 ;
     114GETPCTM(DFN,DATE,ASSTYPE) ;return pc team for a date
     115 ; DFN - pointer to patient file
     116 ; DATE - date of interest
     117 ; ASSTYPE - Default=1 (PC Team)
     118 ; returns sctm
     119 ;
     120 N ACTDT,SCTP,SCPTTMA,INACTDT,SCTM
     121 S ASSTYPE=$G(ASSTYPE,1)
     122 S DATE=$G(DATE,DT)
     123 ; returns pointer to 404.51, if exists, 0 if not
     124 S ACTDT=+$O(^SCPT(404.42,"APCTM",+DFN,+ASSTYPE,(DATE+.000001)),-1)
     125 S SCTM=$O(^SCPT(404.42,"APCTM",+DFN,+ASSTYPE,+ACTDT,0))
     126 S SCPTTMA=$O(^SCPT(404.42,"APCTM",+DFN,+ASSTYPE,+ACTDT,+SCTM,0))
     127 S INACTDT=$P($G(^SCPT(404.42,+SCPTTMA,0)),U,9)
     128 Q $S('INACTDT:+SCTM,(INACTDT'<DATE):+SCTM,1:0)
     129 ;
     130GETPCTP(DFN,DATE,PCROLE) ;return pc position for a date
     131 ; DFN - pointer to patient file
     132 ; DATE - date of interest
     133 ; PCROLE - Default=1 (PC Practitioner Position) note 2= pc attending
     134 ; returns sctp,or 0 if none or -1 if error
     135 ;
     136 N ACTDT,SCTP,SCTM,SCPTA,INACTDT,SCPTTPA,SCOK,TPLP,TPDALP
     137 S SCOK=1,SCTP=0
     138 S DATE=$G(DATE,DT)
     139 S PCROLE=$G(PCROLE,1)
     140 ; returns pointer to 404.57, if exists, 0 if not
     141 S ACTDT=+$O(^SCPT(404.43,"APCPOS",+DFN,+PCROLE,(DATE+.000001)),-1)
     142 F TPLP=0:0 S TPLP=$O(^SCPT(404.43,"APCPOS",+DFN,+PCROLE,+ACTDT,TPLP)) Q:TPLP=""!(SCTP=-1)  F TPDALP=0:0 S TPDALP=$O(^SCPT(404.43,"APCPOS",+DFN,+PCROLE,+ACTDT,TPLP,TPDALP)) Q:TPDALP=""  DO  Q:SCTP=-1
     143 .S INACTDT=$P($G(^SCPT(404.43,+TPDALP,0)),U,4)
     144 .;if already an active date then an error
     145 .I 'INACTDT S SCTP=$S(SCTP>0:-1,1:TPLP) Q
     146 .I INACTDT'<DATE S SCTP=$S(SCTP>0:-1,1:TPLP)
     147 .Q
     148 Q +SCTP
     149 ;
     150GETPRTP(SCTP,DATE) ;returns ien & name of practitioner filling position
     151 ;   Returned [Error:-1,Else: sc200^practname]
     152 N X,SCPRDTS,SCPR
     153 S DATE=$G(DATE,DT)
     154 S SCPRDTS("BEGIN")=DATE
     155 S SCPRDTS("END")=DATE
     156 S X=$$PRTP^SCAPMC(SCTP,"SCPRDTS","SCPR")
     157 Q $S(X<1:-1,1:$P($G(SCPR(1)),U,1)_U_$P($G(SCPR(1)),U,2))
     158 ;
     159EXTMPRTP(SCTP,DATE) ;returns external of team and practitioner for position
     160 ;
     161 N SCX
     162 S SCX=$$GETPRTP(.SCTP,.DATE)
     163 Q $P($G(^SCTM(404.51,+$P($G(^SCTM(404.57,+SCTP,0)),U,2),0)),U,1)_"   "_$P(SCX,U,2)
     164 ;
     165NMPCTP(DFN,DATE,PCROLE) ;returns ien & name of pc position
     166 ; (See GETPCTP for variables)
     167 N X
     168 S X=$$GETPCTP(DFN,.DATE,.PCROLE)
     169 Q $S('$G(X):"",X=-1:"",1:X_U_$P($G(^SCTM(404.57,+X,0)),U,1))
     170 ;
     171NMPCPR(DFN,DATE,PCROLE) ;returns ien & name of pract filling pc position
     172 ; DFN - pointer to patient file
     173 ; DATE - date of interest
     174 ; PCROLE - Practitioner Position where '1' = PC provider
     175 ;                                      '2' = PC attending
     176 ;                                      '3' = PC associate provider
     177 ;
     178 ; returns sctp (ien^name), or "" if none or -1 if error
     179 ;
     180 N SCTP,PCAP
     181 ;bp/cmf 205 original code next line
     182 ;S PCAP=PCROLE S:PCROLE=3 PCROLE=1
     183 ;bp/cmf 205 change code begin
     184 ;;S PCROLE=+$G(PCROLE,1),(PCAP,PCROLE)=$S(PCROLE=0:1,PCROLE>2:1,1:PCROLE)
     185 S (PCROLE,PCAP)=+$G(PCROLE,1)
     186 S PCAP=$S(PCAP=0:1,PCAP>3:1,1:PCAP)
     187 S PCROLE=$S(PCROLE=0:1,PCROLE>2:1,1:PCROLE)
     188 ;bp/cmf 205 change code end
     189 S SCTP=+$$NMPCTP(.DFN,.DATE,.PCROLE)
     190 Q $S('SCTP:"",1:$$PCPROV^SCAPMCU3(SCTP,.DATE,PCAP))
     191 ;
     192NMPCTM(DFN,DATE,PCROLE) ;returns ien & name of pc team
     193 ; (See GETPCTM for variables)
     194 N X
     195 S X=$$GETPCTM(DFN,.DATE,.PCROLE)
     196 Q $S('$G(X):"",1:X_U_$P($G(^SCTM(404.51,+X,0)),U,1))
     197 ;
     198ALPHA(INARRAY,OUTARRAY) ;not supported - for PCMM only
     199 ; returns array sorted by 2nd piece's value
     200 ; it keeps the 0 node -it does not return any x-ref values
     201 ; it only converts arrays of type 1-n to another 1-n array
     202 N SCNDX,SCX,SCNODE,SCY
     203 S (SCX,SCY)=0
     204 S:$D(@INARRAY@(0)) @OUTARRAY@(0)=@INARRAY@(0)
     205 F  S SCX=$O(@INARRAY@(SCX)) Q:'SCX  S SCNODE=@INARRAY@(SCX) Q:'$L(SCNODE)  D
     206 .S ^TMP($J,"SCTMPSORT","B",$P(SCNODE,U,2),SCX)=""
     207 S SCNDX=""
     208 F  S SCNDX=$O(^TMP($J,"SCTMPSORT","B",SCNDX)) Q:SCNDX=""  D
     209 .S SCX=0
     210 .F  S SCX=$O(^TMP($J,"SCTMPSORT","B",SCNDX,SCX)) Q:'SCX  D
     211 ..S SCY=SCY+1
     212 ..S @OUTARRAY@(SCY)=$G(@INARRAY@(SCX))
     213 K ^TMP($J,"SCTMPSORT","B")
     214 Q

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCDD2.m

    r613 r623  
    1 SCMCDD2 ;ALB/REW - DD Calls used by PCMM ; 27 March 1996
    2         ;;5.3;Scheduling;**41,107,520**;AUG 13, 1993;Build 26
    3         ;1
    4 USEPCDEF(SCCL)  ;how should pc practitioner be used for clinic
    5         ; return 2=always default 1=default if no provider listed 0 -never
    6         Q 2
    7 SETSCTM(SCTP,SCCL,SCTMNM)       ;create 'TEAM' x-ref for Hospital Location File (#44)
    8         ; x=sccl, da=sctp sctmnm=name of team
    9         Q:'$G(SCTP)!('$G(SCCL))
    10         S SCTMNM=$G(SCTMNM,$P(^SCTM(404.51,+$P(^SCTM(404.57,SCTP,0),U,2),0),U))
    11         S:$L(SCTMNM) ^SC("TEAM",SCTMNM,+SCCL)=""
    12         Q
    13         ;
    14 KILLSCTM(SCTP,SCCL,SCTMNM)      ;kill 'TEAM' x-ref for File #44 (if no other positions from team have this as associated clinic)
    15         ; x=sccl, da=sctp sctmnm=name of team
    16         N SCTM
    17         Q:'$G(SCTP)!('$G(SCCL))
    18         S SCTM=+$P(^SCTM(404.57,SCTP,0),U,2)
    19         S SCTMNM=$G(SCTMNM,$P(^SCTM(404.51,+SCTM,0),U))
    20         K:$L(SCTMNM)&('$$OKTMCL(SCTM,SCTP,SCCL)) ^SC("TEAM",SCTMNM,+SCCL)
    21         Q
    22 OKTMCL(SCTM,SCTP,SCCL)  ;does team have another position with this clinic as an assoicated clinic?
    23         N SCXTP,SCOK
    24         S SCOK=0
    25         S SCXTP=0
    26         F  S SCXTP=$O(^SCTM(404.57,"E",SCCL,SCXTP)) Q:('SCXTP)!(SCXTP=SCTP)  D
    27         .I $P(^SCTM(404.57,SCXTP,0),U,2)'=SCTM Q
    28         .S SCOK=1
    29         Q SCOK
    30 STSCTMNM(SCTM,SCTMNM)   ;if team name changes - set for 'TEAM' xrefs for file#44
    31         ; sctm=da sctmnm=x
    32         Q:'$G(SCTM)!(SCTMNM="")
    33         N SCTPNM,SCCL
    34         S SCTPNM=""
    35         F  S SCTPNM=$O(^SCTM(404.57,"ATMPOS",SCTM,SCTPNM)) Q:SCTPNM=""  D
    36         .S SCTP=$O(^SCTM(404.57,"ATMPOS",SCTM,SCTPNM,0)) ;note: name is unique
    37         .S SCCL=$P($G(^SCTM(404.57,+SCTP,0)),U,9)
    38         .D:SCCL SETSCTM(SCTP,SCCL,SCTMNM)
    39         Q
    40 KLSCTMNM(SCTM,SCTMNM)   ;if team name changes - kill 'TEAM' xrefs for file #44
    41         ; sctm=da sctmnm=x
    42         Q:'$G(SCTM)!(SCTMNM="")
    43         N SCTPNM,SCCL
    44         S SCTPNM=""
    45         F  S SCTPNM=$O(^SCTM(404.57,"ATMPOS",SCTM,SCTPNM)) Q:SCTPNM=""  D
    46         .S SCTP=$O(^SCTM(404.57,"ATMPOS",SCTM,SCTPNM,0)) ;note: name is unique
    47         .S SCCL=$P($G(^SCTM(404.57,+SCTP,0)),U,9)
    48         .K:SCCL ^SC("TEAM",SCTMNM)
    49         Q
     1SCMCDD2 ;ALB/REW - DD Calls used by PCMM ; 27 March 1996
     2 ;;5.3;Scheduling;**41,107**;AUG 13, 1993
     3 ;1
     4USEPCDEF(SCCL) ;how should pc practitioner be used for clinic
     5 ; return 2=always default 1=default if no provider listed 0 -never
     6 Q 2
     7SETSCTM(SCTP,SCCL,SCTMNM) ;create 'TEAM' x-ref for Hospital Location File (#44)
     8 ; x=sccl, da=sctp sctmnm=name of team
     9 Q:'$G(SCTP)!('$G(SCCL))
     10 S SCTMNM=$G(SCTMNM,$P(^SCTM(404.51,+$P(^SCTM(404.57,SCTP,0),U,2),0),U))
     11 S:$L(SCTMNM) ^SC("TEAM",SCTMNM,+SCCL)=""
     12 Q
     13 ;
     14KILLSCTM(SCTP,SCCL,SCTMNM) ;kill 'TEAM' x-ref for File #44 (if no other positions from team have this as associated clinic)
     15 ; x=sccl, da=sctp sctmnm=name of team
     16 N SCTM
     17 Q:'$G(SCTP)!('$G(SCCL))
     18 S SCTM=+$P(^SCTM(404.57,SCTP,0),U,2)
     19 S SCTMNM=$G(SCTMNM,$P(^SCTM(404.51,+SCTM,0),U))
     20 K:$L(SCTMNM)&('$$OKTMCL(SCTM,SCTP,SCCL)) ^SC("TEAM",SCTMNM,+SCCL)
     21 Q
     22OKTMCL(SCTM,SCTP,SCCL) ;does team have another position with this clinic as an assoicated clinic?
     23 N SCXTP,SCOK
     24 S SCOK=0
     25 S SCXTP=0
     26 F  S SCXTP=$O(^SCTM(404.57,"D",SCCL,SCXTP)) Q:('SCXTP)!(SCXTP=SCTP)  D
     27 .I $P(^SCTM(404.57,SCXTP,0),U,2)'=SCTM Q
     28 .S SCOK=1
     29 Q SCOK
     30STSCTMNM(SCTM,SCTMNM) ;if team name changes - set for 'TEAM' xrefs for file#44
     31 ; sctm=da sctmnm=x
     32 Q:'$G(SCTM)!(SCTMNM="")
     33 N SCTPNM,SCCL
     34 S SCTPNM=""
     35 F  S SCTPNM=$O(^SCTM(404.57,"ATMPOS",SCTM,SCTPNM)) Q:SCTPNM=""  D
     36 .S SCTP=$O(^SCTM(404.57,"ATMPOS",SCTM,SCTPNM,0)) ;note: name is unique
     37 .S SCCL=$P($G(^SCTM(404.57,+SCTP,0)),U,9)
     38 .D:SCCL SETSCTM(SCTP,SCCL,SCTMNM)
     39 Q
     40KLSCTMNM(SCTM,SCTMNM) ;if team name changes - kill 'TEAM' xrefs for file #44
     41 ; sctm=da sctmnm=x
     42 Q:'$G(SCTM)!(SCTMNM="")
     43 N SCTPNM,SCCL
     44 S SCTPNM=""
     45 F  S SCTPNM=$O(^SCTM(404.57,"ATMPOS",SCTM,SCTPNM)) Q:SCTPNM=""  D
     46 .S SCTP=$O(^SCTM(404.57,"ATMPOS",SCTM,SCTPNM,0)) ;note: name is unique
     47 .S SCCL=$P($G(^SCTM(404.57,+SCTP,0)),U,9)
     48 .K:SCCL ^SC("TEAM",SCTMNM)
     49 Q

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCHLB1.m

    r613 r623  
    1 SCMCHLB1        ;BPOI/DJB - PCMM HL7 Bld Segment Array Cont.;8/17/99
    2         ;;5.3;Scheduling;**177,515,524**;08/17/99;Build 29
    3         ;
    4 SEGMENTS(DFN,SUB)       ;Build EVN & PID segments
    5         ;Input:
    6         ;   DFN      - Patient IEN
    7         ;   SUB      - Value for 1st Subscript
    8         ;Output:
    9         ;   XMITARRY() - Array of EVN & PID segments
    10         ;
    11         NEW LINETAG,SEGMENTS,SEGNAME,SEGORD
    12         NEW EVNTDATE,EVNTHL7,VAFARRY,VAFEVN,VAFPID,VAFSTR
    13         ;
    14         ;Initialize variables
    15         Q:'$G(DFN)  ;Required for PID segment
    16         Q:'$G(SUB)
    17         S EVNTDATE=DT
    18         S EVNTHL7="A08"
    19         ;
    20         ;Get array of segments to be built
    21         D SEGMENTS^SCMCHLS(EVNTHL7,"SEGMENTS")
    22         ;
    23         ;Loop thru segments array. Ignore ZPC segment - already built.
    24         S SEGORD=0
    25         F  S SEGORD=+$O(SEGMENTS(SEGORD)) Q:'SEGORD  D  ;
    26         . S SEGNAME=""
    27         . F  S SEGNAME=$O(SEGMENTS(SEGORD,SEGNAME)) Q:SEGNAME=""  D  ;
    28         .. Q:SEGNAME="ZPC"  ;.................ZPC already built
    29         .. S VAFSTR=SEGMENTS(SEGORD,SEGNAME) ;String of segment fields
    30         .. S LINETAG="BLD"_SEGNAME
    31         .. D @LINETAG^SCMCHLS ;...............Build segment
    32         .. S LINETAG="CPY"_SEGNAME
    33         .. D @LINETAG^SCMCHLS ;...............Copy segment into array
    34         Q
    35         ;
    36 ZPC(ARRAY,DELETE)       ;Loop thru array and build array of ZPC segments.
    37         ;
    38         ;Input:
    39         ;   ARRAY  - Array to be processed. This array was built in ^SCMCHLB
    40         ;            with calls to $$PRTPC^SCAPMC() and $$PRPTTPC^SCAPMC().
    41         ;            Examples:
    42         ;               ARRAY(2290,"PCP","2290-406-34-PCP")= Data
    43         ;               ARRAY(345,"PROV-P","2290-405-0-AP")= Data
    44         ;   DELETE - 1=Process a delete type ZPC segment (all fields null)
    45         ;Output:
    46         ;   Array of ZPC segments
    47         ;
    48         NEW DATA,DATE,ID,ID1,LINETAG,SUB,TYPE,VAFZPC
    49         ;
    50         S SUB=0
    51         F  S SUB=$O(ARRAY(SUB)) Q:'SUB  D  ;
    52         . S TYPE=""
    53         . F  S TYPE=$O(ARRAY(SUB,TYPE)) Q:TYPE=""  D  ;
    54         .. S ID=""
    55         .. F  S ID=$O(ARRAY(SUB,TYPE,ID)) Q:ID=""  D  ;
    56         ... S DATA=$G(ARRAY(SUB,TYPE,ID))
    57         ... I $G(DELETE) S DATA="^^^" ;A Delete type ZPC segment
    58         ... E  D  ;....................A ZPC segment with data
    59         .... ;Get dates
    60         .... S DATE(9)=$P(DATA,U,9)
    61         .... S DATE(10)=$P(DATA,U,10)
    62         .... S DATE(14)=$P(DATA,U,14) ;Preceptor start date
    63         .... S DATE(15)=$P(DATA,U,15) ;Preceptor end date
    64         .... I DATE(14),DATE(14)>DATE(9) S DATE(9)=DATE(14)
    65         .... I DATE(15) D  ;
    66         ..... I 'DATE(10) S DATE(10)=DATE(15) Q
    67         ..... I DATE(15)<DATE(10) S DATE(10)=DATE(15)
    68         .... ;
    69         .... ;Provider^AssignDate^UnassignDate^ProviderType
    70         .... S DATA=$P(DATA,U,1)_"^"_DATE(9)_"^"_DATE(10)
    71         ....; PATCH 515 DLL ADD NEW ROLES (TPA,CCM,PM)
    72         ....; OLD CODE = S DATA=DATA_"^"_$S(ID["AP":"AP",1:"PCP")
    73         ....S ROLE=$P(ID,"-",4) I $G(ROLE)="" S ROLE="PCP"
    74         ....S DATA=DATA_"^"_ROLE
    75         ... ;
    76         ... D BLDZPC^SCMCHLS ;..Build segment ; og/sd/524
    77         ... D CPYZPC^SCMCHLS ;..Copy segment into array ; og/sd/524
    78         Q
    79         ;
    80 DFN(ND) ;Find DFN from zero node of Patient Team Position Assign (404.43).
    81         ;Input:
    82         ;   ND  - Zero node of 404.43
    83         ;Output:
    84         ;   DFN - Patient IEN
    85         ;   ""  - No valid DFN found
    86         ;
    87         S DFN=$P(ND,U,1)
    88         I DFN S DFN=$P($G(^SCPT(404.42,DFN,0)),U,1)
    89         Q DFN
    90         ;
    91 ADJID(ARRAY,SCIEN)      ;Adjust ID to include Pt Tm Pos Assign pointer
    92         ;Example:  From this:       424-34-AP
    93         ;            To this:  2290-424-34-AP
    94         ;Input:
    95         ;    ARRAY - Array to be processed
    96         ;    SCIEN - 404.43 IEN to be added to ID
    97         ;
    98         NEW ADJID,ID,NUM,TMP,TYPE
    99         ;
    100         ;Build TMP() array using adjusted ID
    101         S NUM=0
    102         F  S NUM=$O(ARRAY(NUM)) Q:'NUM  D  ;
    103         . S TYPE=""
    104         . F  S TYPE=$O(ARRAY(NUM,TYPE)) Q:TYPE=""  D  ;
    105         .. S ID=""
    106         .. F  S ID=$O(ARRAY(NUM,TYPE,ID)) Q:ID=""  D  ;
    107         ... S ADJID=SCIEN_"-"_ID ;..Add 404.43 IEN
    108         ... S TMP(NUM,TYPE,ADJID)=ARRAY(NUM,TYPE,ID)
    109         ;
    110         ;Replace ARRAY() with adjusted TMP() array.
    111         Q:'$D(TMP)
    112         KILL ARRAY
    113         M ARRAY=TMP ;Copy TMP() into ARRAY()
    114         Q
    115         ;
    116 CHECK(VARPTR)   ;Validate event variable pointer.
    117         ;Input:
    118         ;      VARPTR - EVENT POINTER field of PCMM HL7 EVENT (#404.48)
    119         ;Output:
    120         ;      SCIEN  - IEN portion of variable pointer
    121         ;      SCGLB  - Global portion of variable pointer
    122         ;Return:
    123         ;      0: Invalid variable pointer format
    124         ;      1: Valid pointer
    125         ;      2: No data. Entry has been deleted. Send a delete to NPCD.
    126         ;
    127         NEW CHK,GLB
    128         ;
    129         S SCIEN=$P(VARPTR,";") ;....IEN portion of variable pointer
    130         S SCGLB=$P(VARPTR,";",2) ;..Global portion of variable pointer
    131         ;
    132         ;Return zero if variable pointer is invalid.
    133         I 'SCIEN Q 0
    134         S CHK=0 D  I CHK Q 0
    135         . Q:SCGLB="SCPT(404.43,"
    136         . Q:SCGLB="SCTM(404.52,"
    137         . Q:SCGLB="SCTM(404.53,"
    138         . S CHK=1
    139         ;
    140         ;Is there data for this IEN?
    141         S GLB="^"_SCGLB_SCIEN_",0)"
    142         I '$D(@GLB) Q 2 ;..Entry has been deleted
    143         Q 1
     1SCMCHLB1 ;BP/DJB - PCMM HL7 Bld Segment Array Cont. ; 8/17/99 9:29am
     2 ;;5.3;Scheduling;**177,515**;May 01, 1999;Build 14
     3 ;
     4SEGMENTS(DFN,SUB) ;Build EVN & PID segments
     5 ;Input:
     6 ;   DFN      - Patient IEN
     7 ;   SUB      - Value for 1st Subscript
     8 ;Output:
     9 ;   XMITARRY() - Array of EVN & PID segments
     10 ;
     11 NEW LINETAG,SEGMENTS,SEGNAME,SEGORD
     12 NEW EVNTDATE,EVNTHL7,VAFARRY,VAFEVN,VAFPID,VAFSTR
     13 ;
     14 ;Initialize variables
     15 Q:'$G(DFN)  ;Required for PID segment
     16 Q:'$G(SUB)
     17 S EVNTDATE=DT
     18 S EVNTHL7="A08"
     19 ;
     20 ;Get array of segments to be built
     21 D SEGMENTS^SCMCHLS(EVNTHL7,"SEGMENTS")
     22 ;
     23 ;Loop thru segments array. Ignore ZPC segment - already built.
     24 S SEGORD=0
     25 F  S SEGORD=+$O(SEGMENTS(SEGORD)) Q:'SEGORD  D  ;
     26 . S SEGNAME=""
     27 . F  S SEGNAME=$O(SEGMENTS(SEGORD,SEGNAME)) Q:SEGNAME=""  D  ;
     28 .. Q:SEGNAME="ZPC"  ;.................ZPC already built
     29 .. S VAFSTR=SEGMENTS(SEGORD,SEGNAME) ;String of segment fields
     30 .. S LINETAG="BLD"_SEGNAME
     31 .. D @LINETAG^SCMCHLS ;...............Build segment
     32 .. S LINETAG="CPY"_SEGNAME
     33 .. D @LINETAG^SCMCHLS ;...............Copy segment into array
     34 Q
     35 ;
     36ZPC(ARRAY,DELETE) ;Loop thru array and build array of ZPC segments.
     37 ;
     38 ;Input:
     39 ;   ARRAY  - Array to be processed. This array was built in ^SCMCHLB
     40 ;            with calls to $$PRTPC^SCAPMC() and $$PRPTTPC^SCAPMC().
     41 ;            Examples:
     42 ;               ARRAY(2290,"PCP","2290-406-34-PCP")= Data
     43 ;               ARRAY(345,"PROV-P","2290-405-0-AP")= Data
     44 ;   DELETE - 1=Process a delete type ZPC segment (all fields null)
     45 ;Output:
     46 ;   Array of ZPC segments
     47 ;
     48 NEW DATA,DATE,ID,ID1,LINETAG,NUM,TYPE,VAFZPC
     49 ;
     50 S NUM=0
     51 F  S NUM=$O(ARRAY(NUM)) Q:'NUM  D  ;
     52 . S TYPE=""
     53 . F  S TYPE=$O(ARRAY(NUM,TYPE)) Q:TYPE=""  D  ;
     54 .. S ID=""
     55 .. F  S ID=$O(ARRAY(NUM,TYPE,ID)) Q:ID=""  D  ;
     56 ... S DATA=$G(ARRAY(NUM,TYPE,ID))
     57 ... I $G(DELETE) S DATA="^^^" ;A Delete type ZPC segment
     58 ... E  D  ;....................A ZPC segment with data
     59 .... ;Get dates
     60 .... S DATE(9)=$P(DATA,U,9)
     61 .... S DATE(10)=$P(DATA,U,10)
     62 .... S DATE(14)=$P(DATA,U,14) ;Preceptor start date
     63 .... S DATE(15)=$P(DATA,U,15) ;Preceptor end date
     64 .... I DATE(14),DATE(14)>DATE(9) S DATE(9)=DATE(14)
     65 .... I DATE(15) D  ;
     66 ..... I 'DATE(10) S DATE(10)=DATE(15) Q
     67 ..... I DATE(15)<DATE(10) S DATE(10)=DATE(15)
     68 .... ;
     69 .... ;Provider^AssignDate^UnassignDate^ProviderType
     70 .... S DATA=$P(DATA,U,1)_"^"_DATE(9)_"^"_DATE(10)
     71 ....; PATCH 515 DLL ADD NEW ROLES (TPA,CCM,PM)
     72 ....; OLD CODE = S DATA=DATA_"^"_$S(ID["AP":"AP",1:"PCP")
     73 ....S ROLE=$P(ID,"-",4) I $G(ROLE)="" S ROLE="PCP"
     74 ....S DATA=DATA_"^"_ROLE
     75 ... ;
     76 ... S LINETAG="BLDZPC"
     77 ... D @LINETAG^SCMCHLS ;..Build segment
     78 ... S LINETAG="CPYZPC"
     79 ... D @LINETAG^SCMCHLS ;..Copy segment into array
     80 Q
     81 ;
     82DFN(ND) ;Find DFN from zero node of Patient Team Position Assign (404.43).
     83 ;Input:
     84 ;   ND  - Zero node of 404.43
     85 ;Output:
     86 ;   DFN - Patient IEN
     87 ;   ""  - No valid DFN found
     88 ;
     89 S DFN=$P(ND,U,1)
     90 I DFN S DFN=$P($G(^SCPT(404.42,DFN,0)),U,1)
     91 Q DFN
     92 ;
     93ADJID(ARRAY,SCIEN) ;Adjust ID to include Pt Tm Pos Assign pointer
     94 ;Example:  From this:       424-34-AP
     95 ;            To this:  2290-424-34-AP
     96 ;Input:
     97 ;    ARRAY - Array to be processed
     98 ;    SCIEN - 404.43 IEN to be added to ID
     99 ;
     100 NEW ADJID,ID,NUM,TMP,TYPE
     101 ;
     102 ;Build TMP() array using adjusted ID
     103 S NUM=0
     104 F  S NUM=$O(ARRAY(NUM)) Q:'NUM  D  ;
     105 . S TYPE=""
     106 . F  S TYPE=$O(ARRAY(NUM,TYPE)) Q:TYPE=""  D  ;
     107 .. S ID=""
     108 .. F  S ID=$O(ARRAY(NUM,TYPE,ID)) Q:ID=""  D  ;
     109 ... S ADJID=SCIEN_"-"_ID ;..Add 404.43 IEN
     110 ... S TMP(NUM,TYPE,ADJID)=ARRAY(NUM,TYPE,ID)
     111 ;
     112 ;Replace ARRAY() with adjusted TMP() array.
     113 Q:'$D(TMP)
     114 KILL ARRAY
     115 M ARRAY=TMP ;Copy TMP() into ARRAY()
     116 Q
     117 ;
     118CHECK(VARPTR) ;Validate event variable pointer.
     119 ;Input:
     120 ;      VARPTR - EVENT POINTER field of PCMM HL7 EVENT (#404.48)
     121 ;Output:
     122 ;      SCIEN  - IEN portion of variable pointer
     123 ;      SCGLB  - Global portion of variable pointer
     124 ;Return:
     125 ;      0: Invalid variable pointer format
     126 ;      1: Valid pointer
     127 ;      2: No data. Entry has been deleted. Send a delete to NPCD.
     128 ;
     129 NEW CHK,GLB
     130 ;
     131 S SCIEN=$P(VARPTR,";") ;....IEN portion of variable pointer
     132 S SCGLB=$P(VARPTR,";",2) ;..Global portion of variable pointer
     133 ;
     134 ;Return zero if variable pointer is invalid.
     135 I 'SCIEN Q 0
     136 S CHK=0 D  I CHK Q 0
     137 . Q:SCGLB="SCPT(404.43,"
     138 . Q:SCGLB="SCTM(404.52,"
     139 . Q:SCGLB="SCTM(404.53,"
     140 . S CHK=1
     141 ;
     142 ;Is there data for this IEN?
     143 S GLB="^"_SCGLB_SCIEN_",0)"
     144 I '$D(@GLB) Q 2 ;..Entry has been deleted
     145 Q 1

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCHLB2.m

    r613 r623  
    1 SCMCHLB2        ;BPOI/DJB - PCMM HL7 Bld Segment Array Deletes;3/6/00
    2         ;;5.3;Scheduling;**177,204,210,224,524**;08/13/93;Build 29
    3         ;
    4 PTP     ;Entry has been deleted from file 404.43. Send deletes to NPCD.
    5         ;
    6         NEW DFN,TP
    7         D GETEVENT Q:'DFN  ;..Get DFN & TP from PCMM HL7 EVENT file
    8         D PTPD(SCIEN) ;.......Send delete
    9         ;alb/rpm;Patch 224 Decrement max msg counter
    10         I $D(SCLIMIT) S SCLIMIT=SCLIMIT-1
    11         Q
    12         ;
    13 PTPD(PTPI)      ;From PCMM HL7 ID file, get all ID's whose 1st piece equals PTPI,
    14         ;and send a delete segment.
    15         ;Input: PTPI - 404.43 IEN (1st piece of ID)
    16         ;
    17         ;djb/bp Added SCSEQ per Patch 210[rel 204].
    18         NEW DATA,ID,LINETAG,SCSEQ,VAFZPC
    19         ;
    20         S ID=PTPI_"-"
    21         F  S ID=$O(^SCPT(404.49,"B",ID)) Q:ID=""!($P(ID,"-",1)'=PTPI)  D  ;
    22         . N SUB  ; og/sd/524
    23         . S SUB=PTPI,DATA="^^^" ;........A Delete type ZPC segment
    24         . ;djb/bp Patch 210. Eliminate indirection[rel 204]
    25         . D BLDZPC^SCMCHLS ;..Build segment (needs ID & DATA)
    26         . D CPYZPC^SCMCHLS ;..Copy segment into array (needs ID & VAFZPC)
    27         Q:'$D(@XMITARRY)
    28         D SEGMENTS^SCMCHLB1(DFN,PTPI) ;Bld array of EVN,PID segments
    29         Q
    30         ;
    31 POS     ;Entry has been deleted from file 404.52. Send deletes to NPCD.
    32         ;
    33         NEW DATA,DFN,ID,LINETAG,ND,POS,PTPI,VAFZPC
    34         ;
    35         ;From PCMM HL7 ID file, get all ID's whose 2nd piece equals SCIEN,
    36         ;Build array sorted by:  DFN
    37         ;                        404.43 IEN
    38         ;                        ID
    39         ;djb/bp Fix <STORE> errors for NOIS BIG-1199-71271.
    40         ;       Replace local array POS() with global array.
    41         S POS="^TMP(""PCMM"",""POS"","_$J_")"
    42         KILL @POS
    43         ;
    44         S ID=""
    45         F  S ID=$O(^SCPT(404.49,"B",ID)) Q:ID=""  D  ;
    46         . Q:$P(ID,"-",2)'=SCIEN
    47         . S PTPI=$P(ID,"-",1) ;...............404.43 IEN
    48         . S ND=$G(^SCPT(404.43,PTPI,0))
    49         . Q:($P(ND,U,5)'=1)  ;................Must be Primary Care
    50         . S DFN=$$DFN^SCMCHLB1(ND) Q:'DFN  ;..Get patient
    51         . ;
    52         . S @POS@(DFN,PTPI,ID)="" ;djb/bp BIG-1199-71271
    53         . ;
    54         Q:'$D(@POS)
    55         ;
    56         ;Process array
    57         S DFN=0
    58         F  S DFN=$O(@POS@(DFN)) Q:'DFN  D  ;djb/bp BIG-1199-71271
    59         . S PTPI=0
    60         . F  S PTPI=$O(@POS@(DFN,PTPI)) Q:'PTPI  D  ;djb/bp BIG-1199-71271
    61         .. NEW SCSEQ ;djb/bp Added per Patch 210.
    62         .. ;alb/rpm;Patch 224 Decrement max msg counter
    63         .. I $D(SCLIMIT) S SCLIMIT=SCLIMIT-1
    64         .. D SEGMENTS^SCMCHLB1(DFN,PTPI) ;Bld array of EVN,PID segments
    65         .. S ID=""
    66         .. F  S ID=$O(@POS@(DFN,PTPI,ID)) Q:ID=""  D  ;djb/bp BIG-1199-71271
    67         ... N SUB  ; og/sd/524
    68         ... S SUB=PTPI,DATA="^^^" ;........A Delete type ZPC segment
    69         ... ;djb/bp Patch 210. Eliminate indirection[rel 204]
    70         ... D BLDZPC^SCMCHLS ;..Build segment (needs ID & DATA)
    71         ... D CPYZPC^SCMCHLS ;..Copy segment into array (needs ID & VAFZPC)
    72         ;
    73         KILL @POS ;djb/bp BIG-1199-71271
    74         Q
    75         ;
    76 PRE     ;Entry has been deleted from file 404.53. Send deletes to NPCD.
    77         ;****
    78         ;Currently, deletes to 404.53 are not allowed if there are
    79         ;patients assigned.
    80         ;****
    81         ;alb/rpm;Patch 224 Decrement max msg counter
    82         ;Uncomment the following line if this tag becomes active
    83         ;I $D(SCLIMIT) S SCLIMIT=SCLIMIT-1
    84         Q
    85         ;
    86 GETEVENT        ;Get data from PCMM HL7 EVENT file
    87         ;Return: DFN - Patient IEN
    88         ;        TP  - Team Position
    89         ;
    90         NEW IEN,ND,PTR
    91         ;
    92         ;If in manual mode, get SCEVIEN (404.48 IEN).
    93         I $G(SCMANUAL) D  ;
    94         . S (IEN,SCEVIEN)=0
    95         . F  S IEN=$O(^SCPT(404.48,IEN)) Q:'IEN!SCEVIEN  D  ;
    96         .. S PTR=$P($G(^(IEN,0)),U,7) Q:PTR=""
    97         .. Q:PTR'=VARPTR
    98         .. S SCEVIEN=IEN
    99         ;
    100         S ND=$G(^SCPT(404.48,SCEVIEN,0))
    101         S DFN=$P(ND,U,2) ;..Patient (DFN)
    102         S TP=$P(ND,U,4) ;...Team Position
    103         Q
     1SCMCHLB2 ;BP/DJB - PCMM HL7 Bld Segment Array Deletes ; 3/6/00 8:41am
     2 ;;5.3;Scheduling;**177,204,210,224**;AUG 13, 1993
     3 ;
     4PTP ;Entry has been deleted from file 404.43. Send deletes to NPCD.
     5 ;
     6 NEW DFN,TP
     7 D GETEVENT Q:'DFN  ;..Get DFN & TP from PCMM HL7 EVENT file
     8 D PTPD(SCIEN) ;.......Send delete
     9 ;alb/rpm;Patch 224 Decrement max msg counter
     10 I $D(SCLIMIT) S SCLIMIT=SCLIMIT-1
     11 Q
     12 ;
     13PTPD(PTPI) ;From PCMM HL7 ID file, get all ID's whose 1st piece equals PTPI,
     14 ;and send a delete segment.
     15 ;Input: PTPI - 404.43 IEN (1st piece of ID)
     16 ;
     17 ;djb/bp Added SCSEQ per Patch 210[rel 204].
     18 NEW DATA,ID,LINETAG,SCSEQ,VAFZPC
     19 ;
     20 S ID=PTPI_"-"
     21 F  S ID=$O(^SCPT(404.49,"B",ID)) Q:ID=""!($P(ID,"-",1)'=PTPI)  D  ;
     22 . S DATA="^^^" ;........A Delete type ZPC segment
     23 . ;djb/bp Patch 210. Eliminate indirection[rel 204]
     24 . D BLDZPC^SCMCHLS ;..Build segment (needs ID & DATA)
     25 . D CPYZPC^SCMCHLS ;..Copy segment into array (needs ID & VAFZPC)
     26 Q:'$D(@XMITARRY)
     27 D SEGMENTS^SCMCHLB1(DFN,PTPI) ;Bld array of EVN,PID segments
     28 Q
     29 ;
     30POS ;Entry has been deleted from file 404.52. Send deletes to NPCD.
     31 ;
     32 NEW DATA,DFN,ID,LINETAG,ND,POS,PTPI,VAFZPC
     33 ;
     34 ;From PCMM HL7 ID file, get all ID's whose 2nd piece equals SCIEN,
     35 ;Build array sorted by:  DFN
     36 ;                        404.43 IEN
     37 ;                        ID
     38 ;djb/bp Fix <STORE> errors for NOIS BIG-1199-71271.
     39 ;       Replace local array POS() with global array.
     40 S POS="^TMP(""PCMM"",""POS"","_$J_")"
     41 KILL @POS
     42 ;
     43 S ID=""
     44 F  S ID=$O(^SCPT(404.49,"B",ID)) Q:ID=""  D  ;
     45 . Q:$P(ID,"-",2)'=SCIEN
     46 . S PTPI=$P(ID,"-",1) ;...............404.43 IEN
     47 . S ND=$G(^SCPT(404.43,PTPI,0))
     48 . Q:($P(ND,U,5)'=1)  ;................Must be Primary Care
     49 . S DFN=$$DFN^SCMCHLB1(ND) Q:'DFN  ;..Get patient
     50 . ;
     51 . S @POS@(DFN,PTPI,ID)="" ;djb/bp BIG-1199-71271
     52 . ;
     53 Q:'$D(@POS)
     54 ;
     55 ;Process array
     56 S DFN=0
     57 F  S DFN=$O(@POS@(DFN)) Q:'DFN  D  ;djb/bp BIG-1199-71271
     58 . S PTPI=0
     59 . F  S PTPI=$O(@POS@(DFN,PTPI)) Q:'PTPI  D  ;djb/bp BIG-1199-71271
     60 .. NEW SCSEQ ;djb/bp Added per Patch 210.
     61 .. ;alb/rpm;Patch 224 Decrement max msg counter
     62 .. I $D(SCLIMIT) S SCLIMIT=SCLIMIT-1
     63 .. D SEGMENTS^SCMCHLB1(DFN,PTPI) ;Bld array of EVN,PID segments
     64 .. S ID=""
     65 .. F  S ID=$O(@POS@(DFN,PTPI,ID)) Q:ID=""  D  ;djb/bp BIG-1199-71271
     66 ... S DATA="^^^" ;........A Delete type ZPC segment
     67 ... ;djb/bp Patch 210. Eliminate indirection[rel 204]
     68 ... D BLDZPC^SCMCHLS ;..Build segment (needs ID & DATA)
     69 ... D CPYZPC^SCMCHLS ;..Copy segment into array (needs ID & VAFZPC)
     70 ;
     71 KILL @POS ;djb/bp BIG-1199-71271
     72 Q
     73 ;
     74PRE ;Entry has been deleted from file 404.53. Send deletes to NPCD.
     75 ;****
     76 ;Currently, deletes to 404.53 are not allowed if there are
     77 ;patients assigned.
     78 ;****
     79 ;alb/rpm;Patch 224 Decrement max msg counter
     80 ;Uncomment the following line if this tag becomes active
     81 ;I $D(SCLIMIT) S SCLIMIT=SCLIMIT-1
     82 Q
     83 ;
     84GETEVENT ;Get data from PCMM HL7 EVENT file
     85 ;Return: DFN - Patient IEN
     86 ;        TP  - Team Position
     87 ;
     88 NEW IEN,ND,PTR
     89 ;
     90 ;If in manual mode, get SCEVIEN (404.48 IEN).
     91 I $G(SCMANUAL) D  ;
     92 . S (IEN,SCEVIEN)=0
     93 . F  S IEN=$O(^SCPT(404.48,IEN)) Q:'IEN!SCEVIEN  D  ;
     94 .. S PTR=$P($G(^(IEN,0)),U,7) Q:PTR=""
     95 .. Q:PTR'=VARPTR
     96 .. S SCEVIEN=IEN
     97 ;
     98 S ND=$G(^SCPT(404.48,SCEVIEN,0))
     99 S DFN=$P(ND,U,2) ;..Patient (DFN)
     100 S TP=$P(ND,U,4) ;...Team Position
     101 Q

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCHLR2.m

    r613 r623  
    1 SCMCHLR2        ;ALB/KCL - PCMM HL7 Reject Processing - Build List Area; 10-JAN-2000  ; Compiled April 24, 2007 11:44:10
    2         ;;5.3;Scheduling;**210,272,297,458**;AUG 13, 1993;Build 14
    3         ;
    4 EN(SCARY,SCBEG,SCEND,SCEPS,SCSORTBY,SCCNT)      ;
    5         ; Description: This entry point is used to build list area for
    6         ; PCMM Transmission Errors.
    7         ;
    8         ; The following variables are 'system wide variables' in the
    9         ; PCMM Transmission Error Processing List Manager application:
    10         ;  Input:
    11         ;      SCARY - Global array subscript
    12         ;      SCBEG - Begin date for date range
    13         ;      SCEND - End date for date range
    14         ;      SCEPS - Error processing statuses
    15         ;                1 -> New
    16         ;                2 -> Checked
    17         ;                3 -> Both
    18         ;   SCSORTBY - Sort by criteria
    19         ;                N -> Patient Name
    20         ;                D -> Date/Time Ack Received
    21         ;                P -> Provider
    22         ;
    23         ; Output:
    24         ;  SCCNT - Contains number of lines in the list, pass by reference
    25         ;
    26         ;Display FM wait msg
    27         D WAIT^DICD
    28         ;
    29         ;Get PCMM HL7 Trans Log errors
    30         D GET(SCARY,SCBEG,SCEND,SCEPS,SCSORTBY)
    31         ;
    32         ;Build list area for PCMM HL7 Trans Log errors
    33         D BLDLIST^SCMCHLR3(SCSORTBY,SCEPS,.SCCNT)
    34         ;
    35         ;If no PCMM HL7 Trans Log errors, display msg in list area
    36         I 'SCCNT D
    37         .D SET^SCMCHLR3(SCARY,1,"",1,36,0,,,,.SCCNT)
    38         .D SET^SCMCHLR3(SCARY,2,"No 'PCMM Transmission Errors' to display.",4,41,0,,,,.SCCNT)
    39         Q
    40         ;
    41         ;
    42 GET(SCARY,SCBEG,SCEND,SCEPS,SCSORTBY)   ;
    43         ; Description: Get PCMM HL7 Transmission Log errors.
    44         ;
    45         ;  Input:
    46         ;      SCARY - Global array subscript
    47         ;      SCBEG - Begin date for date range
    48         ;      SCEND - End date for date range
    49         ;      SCEPS - Error processing status
    50         ;   SCSORTBY - Sort by criteria
    51         ;
    52         ; Output:
    53         ;  PCMM transmission log error list sorted by:
    54         ;
    55         ;   Patient Name: ^TMP("SCERRSRT",$J,<sort by>,<patient name>,<trans log IEN>,<err code ien>)
    56         ; OR,
    57         ;   Date/Time Ack Rec'd: ^TMP("SCERRSRT",$J,<sort by>,<date/time ack rec'd>,<trans log IEN>,<err code ien>)
    58         ; OR,
    59         ;   Provider: ^TMP("SCERRSRT",$J,<sort by>,<provider>,<trans log IEN>,<err code ien>)
    60         ;
    61         N SCDFN,SCDTR,SCERIEN,SCTLIEN,SCSTAT
    62         ;
    63         ;Loop thru PCMM HL7 Trans Log for selected date range
    64         F SCDTR=SCBEG:0 S SCDTR=$O(^SCPT(404.471,"AST",SCDTR)) Q:'SCDTR!($P(SCDTR,".")>SCEND)  D
    65         .;loop thru status
    66         .S SCSTAT=0
    67         .F  S SCSTAT=$O(^SCPT(404.471,"AST",SCDTR,SCSTAT)) Q:SCSTAT=""  D
    68         ..;loop thru patients
    69         ..S SCDFN=0
    70         ..F  S SCDFN=$O(^SCPT(404.471,"AST",SCDTR,SCSTAT,SCDFN)) Q:SCDFN=""  D
    71         ...;loop through (#404.471) ien's
    72         ...S SCTLIEN=0
    73         ...F  S SCTLIEN=$O(^SCPT(404.471,"AST",SCDTR,SCSTAT,SCDFN,SCTLIEN)) Q:'SCTLIEN  D
    74         ....;loop thru ien's of error code mult. and setup sort array
    75         ....S SCERIEN=0
    76         ....F  S SCERIEN=$O(^SCPT(404.471,SCTLIEN,"ERR",SCERIEN)) Q:'SCERIEN  D SORT(SCSORTBY,SCDTR,SCDFN,SCEPS,SCTLIEN,SCERIEN)
    77         ;
    78         Q
    79         ;
    80         ;
    81 SORT(SCSORTBY,SCDTR,SCDFN,SCEPS,SCTLIEN,SCERIEN)        ;
    82         ; Description: Used to set up sort array based on 'Sort Criteria' and
    83         ; 'Error Processing Status' for PCMM Transmission Errors list display.
    84         ;
    85         ;  Input:
    86         ;   SCSORTBY - Sort by criteria
    87         ;      SCDTR - PCMM transmission log date/time ack received
    88         ;      SCDFN - Patient IEN
    89         ;      SCEPS - Error processing status
    90         ;    SCTLIEN - PCMM transmission log IEN
    91         ;    SCERIEN - IEN of record in Error Code (#404.47142) multiple
    92         ;
    93         ; Output: None
    94         ;
    95         N SCTLOG
    96         ;
    97         ;If sort by criteria is 'Date/Time Ack Received'
    98         I SCSORTBY="D" D
    99         .;get data from PCMM HL7 Trans Log
    100         .I $$GETLOG^SCMCHLA(SCTLIEN,SCERIEN,.SCTLOG) D
    101         ..;if Error Proc Status matches selected Error Proc Status
    102         ..I (SCEPS=$G(SCTLOG("ERR","EPS"))!(SCEPS>2)) D
    103         ...;setup ^tmp array sorted by date/time ack rec'd
    104         ...S ^TMP("SCERRSRT",$J,SCSORTBY,SCDTR,SCTLIEN,SCERIEN)=""
    105         ;
    106         ;If sort by criteria is 'Provider'
    107         I SCSORTBY="P" D
    108         .N SCPTR,SCPROV,SCHL
    109         .;get data from PCMM HL7 Trans Log
    110         .I $$GETLOG^SCMCHLA(SCTLIEN,SCERIEN,.SCTLOG) D
    111         ..;if Error Proc Status matches selected Error Proc Status
    112         ..I (SCEPS=$G(SCTLOG("ERR","EPS"))!(SCEPS>2)) D
    113         ...;get data from PCMM HL7 ID file
    114         ...I $$GETHL7ID^SCMCHLA2($G(SCTLOG("ERR","ZPCID")),.SCHL) D
    115         ....;get provider from POSITION ASSIGNMENT HISTORY file
    116         ....S SCPTR=$P($G(SCHL("HL7ID")),"-",2)  ; pointer to PCMM HL7 ID file
    117         ....I $G(SCTLOG("WORK")) S SCPROV=$$PROV^SCMCHLP(SCTLOG("WORK"))
    118         ....I '$G(SCTLOG("WORK")) S SCPROV=$P($G(^SCTM(404.52,+SCPTR,0)),"^",3)
    119         ....;setup ^tmp array sorted by provider
    120         ....S ^TMP("SCERRSRT",$J,SCSORTBY,$S($G(SCPROV)'="":$$EXTERNAL^DILFD(404.52,.03,,SCPROV),1:"ZZZUNKNOWN"),SCTLIEN,SCERIEN)=""
    121         ;
    122         ;If sort by criteria is 'Patient' (default)
    123         I SCSORTBY="N" D
    124         .;get data from PCMM HL7 Trans Log
    125         .I $$GETLOG^SCMCHLA(SCTLIEN,SCERIEN,.SCTLOG) D
    126         ..;if Error Proc Status matches selected Error Proc Status
    127         ..I (SCEPS=$G(SCTLOG("ERR","EPS"))!(SCEPS>2)) D
    128         ...;setup ^tmp array sorted by patient
    129         ...I SCDFN="W" I $G(SCTLOG("WORK"))="" S SCDFN=""
    130         ...S ^TMP("SCERRSRT",$J,SCSORTBY,$S($P($G(^DPT(+SCDFN,0)),U)'="":$P(^(0),U),SCDFN="W":"Workload Message",1:"UNKNOWN"),SCTLIEN,SCERIEN)=""
    131         ;
    132         Q
     1SCMCHLR2 ;ALB/KCL - PCMM HL7 Reject Processing - Build List Area; 10-JAN-2000
     2 ;;5.3;Scheduling;**210,272,297**;AUG 13, 1993
     3 ;
     4EN(SCARY,SCBEG,SCEND,SCEPS,SCSORTBY,SCCNT) ;
     5 ; Description: This entry point is used to build list area for
     6 ; PCMM Transmission Errors.
     7 ;
     8 ; The following variables are 'system wide variables' in the
     9 ; PCMM Transmission Error Processing List Manager application:
     10 ;  Input:
     11 ;      SCARY - Global array subscript
     12 ;      SCBEG - Begin date for date range
     13 ;      SCEND - End date for date range
     14 ;      SCEPS - Error processing statuses
     15 ;                1 -> New
     16 ;                2 -> Checked
     17 ;                3 -> Both
     18 ;   SCSORTBY - Sort by criteria
     19 ;                N -> Patient Name
     20 ;                D -> Date/Time Ack Received
     21 ;                P -> Provider
     22 ;
     23 ; Output:
     24 ;  SCCNT - Contains number of lines in the list, pass by reference
     25 ;
     26 ;Display FM wait msg
     27 D WAIT^DICD
     28 ;
     29 ;Get PCMM HL7 Trans Log errors
     30 D GET(SCARY,SCBEG,SCEND,SCEPS,SCSORTBY)
     31 ;
     32 ;Build list area for PCMM HL7 Trans Log errors
     33 D BLDLIST^SCMCHLR3(SCSORTBY,SCEPS,.SCCNT)
     34 ;
     35 ;If no PCMM HL7 Trans Log errors, display msg in list area
     36 I 'SCCNT D
     37 .D SET^SCMCHLR3(SCARY,1,"",1,36,0,,,,.SCCNT)
     38 .D SET^SCMCHLR3(SCARY,2,"No 'PCMM Transmission Errors' to display.",4,41,0,,,,.SCCNT)
     39 Q
     40 ;
     41 ;
     42GET(SCARY,SCBEG,SCEND,SCEPS,SCSORTBY) ;
     43 ; Description: Get PCMM HL7 Transmission Log errors.
     44 ;
     45 ;  Input:
     46 ;      SCARY - Global array subscript
     47 ;      SCBEG - Begin date for date range
     48 ;      SCEND - End date for date range
     49 ;      SCEPS - Error processing status
     50 ;   SCSORTBY - Sort by criteria
     51 ;
     52 ; Output:
     53 ;  PCMM transmission log error list sorted by:
     54 ;
     55 ;   Patient Name: ^TMP("SCERRSRT",$J,<sort by>,<patient name>,<trans log IEN>,<err code ien>)
     56 ; OR,
     57 ;   Date/Time Ack Rec'd: ^TMP("SCERRSRT",$J,<sort by>,<date/time ack rec'd>,<trans log IEN>,<err code ien>)
     58 ; OR,
     59 ;   Provider: ^TMP("SCERRSRT",$J,<sort by>,<provider>,<trans log IEN>,<err code ien>)
     60 ;
     61 N SCDFN,SCDTR,SCERIEN,SCTLIEN,SCSTAT
     62 ;
     63 ;Loop thru PCMM HL7 Trans Log for selected date range
     64 F SCDTR=SCBEG:0 S SCDTR=$O(^SCPT(404.471,"AST",SCDTR)) Q:'SCDTR!($P(SCDTR,".")>SCEND)  D
     65 .;loop thru status
     66 .S SCSTAT=0
     67 .F  S SCSTAT=$O(^SCPT(404.471,"AST",SCDTR,SCSTAT)) Q:SCSTAT=""  D
     68 ..;loop thru patients
     69 ..S SCDFN=0
     70 ..F  S SCDFN=$O(^SCPT(404.471,"AST",SCDTR,SCSTAT,SCDFN)) Q:SCDFN=""  D
     71 ...;loop through (#404.471) ien's
     72 ...S SCTLIEN=0
     73 ...F  S SCTLIEN=$O(^SCPT(404.471,"AST",SCDTR,SCSTAT,SCDFN,SCTLIEN)) Q:'SCTLIEN  D
     74 ....;loop thru ien's of error code mult. and setup sort array
     75 ....S SCERIEN=0
     76 ....F  S SCERIEN=$O(^SCPT(404.471,SCTLIEN,"ERR",SCERIEN)) Q:'SCERIEN  D SORT(SCSORTBY,SCDTR,SCDFN,SCEPS,SCTLIEN,SCERIEN)
     77 ;
     78 Q
     79 ;
     80 ;
     81SORT(SCSORTBY,SCDTR,SCDFN,SCEPS,SCTLIEN,SCERIEN) ;
     82 ; Description: Used to set up sort array based on 'Sort Criteria' and
     83 ; 'Error Processing Status' for PCMM Transmission Errors list display.
     84 ;
     85 ;  Input:
     86 ;   SCSORTBY - Sort by criteria
     87 ;      SCDTR - PCMM transmission log date/time ack received
     88 ;      SCDFN - Patient IEN
     89 ;      SCEPS - Error processing status
     90 ;    SCTLIEN - PCMM transmission log IEN
     91 ;    SCERIEN - IEN of record in Error Code (#404.47142) multiple
     92 ;
     93 ; Output: None
     94 ;
     95 N SCTLOG
     96 ;
     97 ;If sort by criteria is 'Date/Time Ack Received'
     98 I SCSORTBY="D" D
     99 .;get data from PCMM HL7 Trans Log
     100 .I $$GETLOG^SCMCHLA(SCTLIEN,SCERIEN,.SCTLOG) D
     101 ..;if Error Proc Status matches selected Error Proc Status
     102 ..I (SCEPS=$G(SCTLOG("ERR","EPS"))!(SCEPS>2)) D
     103 ...;setup ^tmp array sorted by date/time ack rec'd
     104 ...S ^TMP("SCERRSRT",$J,SCSORTBY,SCDTR,SCTLIEN,SCERIEN)=""
     105 ;
     106 ;If sort by criteria is 'Provider'
     107 I SCSORTBY="P" D
     108 .N SCPTR,SCPROV,SCHL
     109 .;get data from PCMM HL7 Trans Log
     110 .I $$GETLOG^SCMCHLA(SCTLIEN,SCERIEN,.SCTLOG) D
     111 ..;if Error Proc Status matches selected Error Proc Status
     112 ..I (SCEPS=$G(SCTLOG("ERR","EPS"))!(SCEPS>2)) D
     113 ...;get data from PCMM HL7 ID file
     114 ...I $$GETHL7ID^SCMCHLA2($G(SCTLOG("ERR","ZPCID")),.SCHL)
     115 ...;get provider from POSITION ASSIGNMENT HISTORY file
     116 ...S SCPTR=$P($G(SCHL("HL7ID")),"-",2)  ; pointer to PCMM HL7 ID file
     117 ...I $G(SCTLOG("WORK")) S SCPROV=$$PROV^SCMCHLP(SCTLOG("WORK"))
     118 ...I '$G(SCTLOG("WORK")) S SCPROV=$P($G(^SCTM(404.52,+SCPTR,0)),"^",3)
     119 ...;setup ^tmp array sorted by provider
     120 ...S ^TMP("SCERRSRT",$J,SCSORTBY,$S($G(SCPROV)'="":$$EXTERNAL^DILFD(404.52,.03,,SCPROV),1:"ZZZUNKNOWN"),SCTLIEN,SCERIEN)=""
     121 ;
     122 ;If sort by criteria is 'Patient' (default)
     123 I SCSORTBY="N" D
     124 .;get data from PCMM HL7 Trans Log
     125 .I $$GETLOG^SCMCHLA(SCTLIEN,SCERIEN,.SCTLOG) D
     126 ..;if Error Proc Status matches selected Error Proc Status
     127 ..I (SCEPS=$G(SCTLOG("ERR","EPS"))!(SCEPS>2)) D
     128 ...;setup ^tmp array sorted by patient
     129 ...I SCDFN="W" I $G(SCTLOG("WORK"))="" S SCDFN=""
     130 ...S ^TMP("SCERRSRT",$J,SCSORTBY,$S($P($G(^DPT(+SCDFN,0)),U)'="":$P(^(0),U),SCDFN="W":"Workload Message",1:"UNKNOWN"),SCTLIEN,SCERIEN)=""
     131 ;
     132 Q

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCHLS.m

    r613 r623  
    1 SCMCHLS ;BPOI/DJB - PCMM HL7 Segment Utils;12/13/99
    2         ;;5.3;Scheduling;**177,210,212,293,515,524**;08/13/93;Build 29
    3         ;
    4         ;Ref rtn: SCDXMSG1
    5         ;
    6         ;--> Build HL7 segments
    7 BLDEVN  ;Build EVN segment
    8         S VAFEVN=$$EN^VAFHLEVN(EVNTHL7,EVNTDATE,VAFSTR,HL("Q"),HL("FS"))
    9         Q
    10 BLDPID  ;Build PID segment
    11         ;S VAFPID=$$EN^VAFHLPID(DFN,VAFSTR)
    12         S VAFPID=$$EN^VAFCPID(DFN,VAFSTR) ;Use CIRN version
    13         D SETMAR^SCMSVUT0(.VAFPID,HL("Q"),HL("FS"))
    14         Q
    15 BLDZPC  ;Build ZPC segment
    16         ;djb/bp Patch 210. Sequentially number multiple ZPC segments.
    17         ;new code begin
    18         S SCSEQ=$G(SCSEQ)+1 ;Increment ZPC sequence number.
    19         ; S VAFZPC=$$ZPC^SCMCHLZ("",ID,DATA,SCSEQ)
    20         S VAFZPC=$$ZPC^SCMCHLZ("",.ID,.DATA,SCSEQ)
    21         ;new code end
    22         ;old code begin
    23         ;S VAFZPC=$$ZPC^SCMCHLZ("",ID,DATA)
    24         ;old code end
    25         Q
    26         ;
    27         ;--> Copy HL7 segments into HL7 message
    28 CPYEVN  ;Copy EVN segment
    29         ;Add 1 as 3rd subscript so number of subscripts matches ZPC segment
    30         M @XMITARRY@(SUB,SEGNAME,1)=VAFEVN
    31         Q
    32 CPYPID  ;Copy PID segment
    33         ;Add 1 as 3rd subscript so number of subscripts matches ZPC segment
    34         M @XMITARRY@(SUB,SEGNAME,1)=VAFPID
    35         Q
    36 CPYZPC  ;Copy ZPC segment
    37         ; PATCH 515 DLL USE ORIG TRIG
    38         ; old code = M @XMITARRY@($P(ID,"-",1),"ZPC",ID)=VAFZPC
    39         M @XMITARRY@(SUB,"ZPC",ID)=VAFZPC  ; og/sd/524
    40         Q
    41         ;
    42         ;--> Delete HL7 segment variables
    43 DELEVN  ;Delete EVN variable
    44         KILL VAFEVN
    45         Q
    46 DELPID  ;Delete PID variable
    47         KILL VAFPID
    48         Q
    49 DELZPC  ;Delete ZPC variable
    50         KILL VAFZPC
    51         Q
    52         ;
    53 SEGMENTS(EVNTTYPE,SEGARRY)      ;Build list of HL7 segments for a given event type
    54         ;
    55         ; Input: EVNTTYPE - Event type to build list for A08 & A23 are the
    56         ;                   only types currently supported.
    57         ;                   Default=A08
    58         ;         SEGARRY - Array to place output in (full global reference)
    59         ;                   Defaul=^TMP("SCMC SEGMENTS",$J)
    60         ;Output: SEGARRY(Seq,Name)=Fields
    61         ;             Seq - Sequence number to order segments as they should
    62         ;                   be placed in the HL7 message.
    63         ;            Name - Name of HL7 segment.
    64         ;          Fields - List of fields used by PCMM. VAFSTR would be set
    65         ;                   to this value.
    66         ;  Note: MSH segment is not included
    67         ;
    68         ;Check input
    69         S EVNTTYPE=$G(EVNTTYPE)
    70         S:(EVNTTYPE'="A23") EVNTTYPE="A08"
    71         S SEGARRY=$G(SEGARRY)
    72         S:(SEGARRY="") SEGARRY="^TMP(""SCMC SEGMENTS"","_$J_")"
    73         ;
    74         ;Segments used by A08
    75         S @SEGARRY@(1,"EVN")="1,2"
    76         S @SEGARRY@(2,"PID")="1,2,3,4,5,6,7,8,10N,11,12,13,14,16,17,19,22"
    77         S @SEGARRY@(3,"ZPC")="1,2,3,4,5,6,8" ;bp/ar and alb/rpm Patch 212
    78         Q
    79         ;
    80 UNWIND(XMITARRY,INSRTPNT)       ;Remove all data that was put into transmit array.
    81         ;
    82         ; Input: XMITARRY - Array containing HL7 message (full global ref).
    83         ;                   Default=^TMP("HLS",$J).
    84         ;        INSRTPNT - Where to begin deletion from.
    85         ;                   Default=1
    86         ;Output: None
    87         ;
    88         ;Check input
    89         S:$G(XMITARRY)="" XMITARRY="^TMP(""HLS"","_$J_")"
    90         S:$G(INSRTPNT)="" INSRTPNT=1
    91         ;
    92         ;Remove insertion point from array
    93         KILL @XMITARRY@(INSRTPNT)
    94         ;Remove everything from insertion point to end of array
    95         F  S INSRTPNT=$O(@XMITARRY@(INSRTPNT)) Q:INSRTPNT=""  KILL @XMITARRY@(INSRTPNT)
    96         ;Done
    97         Q
    98 COUNT(VALER)    ;counts the number of errored encounters found.
    99         ;
    100         ; Input: VALER - Array containing error messages.
    101         ;Output: Number of errors
    102         ;
    103         NEW VAR,CNT
    104         S CNT=0
    105         S VAR=""
    106         F  S VAR=$O(@VALER@(VAR)) Q:VAR']""  S CNT=CNT+1
    107         Q CNT
     1SCMCHLS ;BP/DJB - PCMM HL7 Segment Utils ; 12/13/99 12:40pm
     2 ;;5.3;Scheduling;**177,210,212,293,515**;AUG 13, 1993;Build 14
     3 ;
     4 ;Ref rtn: SCDXMSG1
     5 ;
     6 ;--> Build HL7 segments
     7BLDEVN ;Build EVN segment
     8 S VAFEVN=$$EN^VAFHLEVN(EVNTHL7,EVNTDATE,VAFSTR,HL("Q"),HL("FS"))
     9 Q
     10BLDPID ;Build PID segment
     11 ;S VAFPID=$$EN^VAFHLPID(DFN,VAFSTR)
     12 S VAFPID=$$EN^VAFCPID(DFN,VAFSTR) ;Use CIRN version
     13 D SETMAR^SCMSVUT0(.VAFPID,HL("Q"),HL("FS"))
     14 Q
     15BLDZPC ;Build ZPC segment
     16 ;djb/bp Patch 210. Sequentially number multiple ZPC segments.
     17 ;new code begin
     18 S SCSEQ=$G(SCSEQ)+1 ;Increment ZPC sequence number.
     19 ; S VAFZPC=$$ZPC^SCMCHLZ("",ID,DATA,SCSEQ)
     20 S VAFZPC=$$ZPC^SCMCHLZ("",.ID,.DATA,SCSEQ)
     21 ;new code end
     22 ;old code begin
     23 ;S VAFZPC=$$ZPC^SCMCHLZ("",ID,DATA)
     24 ;old code end
     25 Q
     26 ;
     27 ;--> Copy HL7 segments into HL7 message
     28CPYEVN ;Copy EVN segment
     29 ;Add 1 as 3rd subscript so number of subscripts matches ZPC segment
     30 M @XMITARRY@(SUB,SEGNAME,1)=VAFEVN
     31 Q
     32CPYPID ;Copy PID segment
     33 ;Add 1 as 3rd subscript so number of subscripts matches ZPC segment
     34 M @XMITARRY@(SUB,SEGNAME,1)=VAFPID
     35 Q
     36CPYZPC ;Copy ZPC segment
     37 ; PATCH 515 DLL USE ORIG TRIG
     38 ; old code = M @XMITARRY@($P(ID,"-",1),"ZPC",ID)=VAFZPC
     39 M @XMITARRY@(NUM,"ZPC",ID)=VAFZPC
     40 Q
     41 ;
     42 ;--> Delete HL7 segment variables
     43DELEVN ;Delete EVN variable
     44 KILL VAFEVN
     45 Q
     46DELPID ;Delete PID variable
     47 KILL VAFPID
     48 Q
     49DELZPC ;Delete ZPC variable
     50 KILL VAFZPC
     51 Q
     52 ;
     53SEGMENTS(EVNTTYPE,SEGARRY) ;Build list of HL7 segments for a given event type
     54 ;
     55 ; Input: EVNTTYPE - Event type to build list for A08 & A23 are the
     56 ;                   only types currently supported.
     57 ;                   Default=A08
     58 ;         SEGARRY - Array to place output in (full global reference)
     59 ;                   Defaul=^TMP("SCMC SEGMENTS",$J)
     60 ;Output: SEGARRY(Seq,Name)=Fields
     61 ;             Seq - Sequence number to order segments as they should
     62 ;                   be placed in the HL7 message.
     63 ;            Name - Name of HL7 segment.
     64 ;          Fields - List of fields used by PCMM. VAFSTR would be set
     65 ;                   to this value.
     66 ;  Note: MSH segment is not included
     67 ;
     68 ;Check input
     69 S EVNTTYPE=$G(EVNTTYPE)
     70 S:(EVNTTYPE'="A23") EVNTTYPE="A08"
     71 S SEGARRY=$G(SEGARRY)
     72 S:(SEGARRY="") SEGARRY="^TMP(""SCMC SEGMENTS"","_$J_")"
     73 ;
     74 ;Segments used by A08
     75 S @SEGARRY@(1,"EVN")="1,2"
     76 S @SEGARRY@(2,"PID")="1,2,3,4,5,6,7,8,10N,11,12,13,14,16,17,19,22"
     77 S @SEGARRY@(3,"ZPC")="1,2,3,4,5,6,8" ;bp/ar and alb/rpm Patch 212
     78 Q
     79 ;
     80UNWIND(XMITARRY,INSRTPNT) ;Remove all data that was put into transmit array.
     81 ;
     82 ; Input: XMITARRY - Array containing HL7 message (full global ref).
     83 ;                   Default=^TMP("HLS",$J).
     84 ;        INSRTPNT - Where to begin deletion from.
     85 ;                   Default=1
     86 ;Output: None
     87 ;
     88 ;Check input
     89 S:$G(XMITARRY)="" XMITARRY="^TMP(""HLS"","_$J_")"
     90 S:$G(INSRTPNT)="" INSRTPNT=1
     91 ;
     92 ;Remove insertion point from array
     93 KILL @XMITARRY@(INSRTPNT)
     94 ;Remove everything from insertion point to end of array
     95 F  S INSRTPNT=$O(@XMITARRY@(INSRTPNT)) Q:INSRTPNT=""  KILL @XMITARRY@(INSRTPNT)
     96 ;Done
     97 Q
     98COUNT(VALER) ;counts the number of errored encounters found.
     99 ;
     100 ; Input: VALER - Array containing error messages.
     101 ;Output: Number of errors
     102 ;
     103 NEW VAR,CNT
     104 S CNT=0
     105 S VAR=""
     106 F  S VAR=$O(@VALER@(VAR)) Q:VAR']""  S CNT=CNT+1
     107 Q CNT

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCMU2.m

    r613 r623  
    1 SCMCMU2 ;ALBOI/MJK - PCMM Mass Team/Position Unassignment Processing;07/10/98
    2         ;;5.3;Scheduling;**148,177,524**;AUG 13, 1993;Build 29
    3         ;
    4 QUE()   ; -- queue mass unassignment
    5         ;D START Q 99999 ; -- for interactive testing
    6         N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSAVE,ZTSK
    7         S ZTRTN="START^SCMCMU2"
    8         S ZTDESC=VALM("TITLE")
    9         S ZTDTH=$H
    10         S ZTIO=""
    11         F X="SCTEAM","SCPOS","SCTPDIS(","SCMUTYPE","SCDATE","SCSELCNT" S ZTSAVE(X)=""
    12         F X="^TMP(""SCMU"",$J,""SELECTED"",","^TMP(""SCMU"",$J,""PATIENT INFO""," S ZTSAVE(X)=""
    13         D ^%ZTLOAD
    14         Q $G(ZTSK)
    15         ;
    16 START   ; -- entry point for task
    17         ; -- defined from task SCTEAM,SCPOS,SCTPDIS,SCMUTYPE,SCDATE,SCSELCNT
    18         ;
    19         N SCTOP,SCUNCNT,SCASCNT,SCOK
    20         S SCUNCNT=0
    21         S SCASCNT=SCSELCNT
    22         ;
    23         ; -- lock top node
    24         IF SCMUTYPE="T" D
    25         . S SCTOP=$NA(^SCTM(404.51,+SCTEAM,0))
    26         ELSE  IF SCMUTYPE="P" D
    27         . S SCTOP=$NA(^SCTM(404.57,+SCPOS,0))
    28         D LOCK(SCTOP)
    29         ;
    30         ; -- use tmp data brought in by TaskMan
    31         N SCPTSEL,SCPTINFO
    32         S SCPTSEL=$NA(^TMP("SCMU",$J,"SELECTED"))
    33         S SCPTINFO=$NA(^TMP("SCMU",$J,"PATIENT INFO"))
    34         ;
    35         N SCOKAR,SCBADAR,SCERRAR,SCPTTP
    36         S SCOKAR=$NA(^TMP("SCMU",$J,"OK"))
    37         S SCBADAR=$NA(^TMP("SCMU",$J,"BAD"))
    38         S SCERRAR=$NA(^TMP("SCMU",$J,"ERROR"))
    39         S SCPTTP=$NA(^TMP("SCMU",$J,"PATIENT-POSITION"))
    40         K @SCOKAR,@SCBADAR,@SCERRAR,@SCPTTP
    41         ;
    42         N SCNT,SCNODE,SCPTX
    43         ;
    44         ; -- create patient-position array for team processing
    45         IF SCMUTYPE="T" D PTTPLST^SCMCMU11(SCTEAM,SCDATE,SCPTTP)
    46         ;
    47         S SCNT=0
    48         F  S SCNT=$O(@SCPTSEL@(SCNT)) Q:'SCNT  D
    49         . ;N SCDATE S SCDATE=2700101 ; -- use to force error/testing
    50         . S SCPTX=$G(@SCPTINFO@(SCNT))
    51         . IF SCPTX="" Q
    52         . IF SCMUTYPE="T" S SCOK=$$TMDIS(SCDATE,SCTEAM,SCNT,SCPTX)
    53         . ;
    54         . IF SCMUTYPE="P" S SCOK=$$TPDIS(SCDATE,SCPOS,SCNT,SCPTX)
    55         . ;
    56         . ; -- if successful
    57         . IF SCOK D
    58         . . S @SCOKAR@(SCNT)=""
    59         . . S SCUNCNT=SCUNCNT+1
    60         . . S SCASCNT=SCASCNT-1
    61         . ;
    62         . ; -- if not sucessful
    63         . ELSE  D
    64         . . S @SCBADAR@(SCNT)=""
    65         ;
    66         ; -- unlock top node
    67         D UNLOCK(SCTOP)
    68         ;
    69         ; -- send results
    70         D BULL^SCMCMU4
    71         ;
    72         K @SCOKAR,@SCBADAR,@SCERRAR,@SCPTTP
    73         K @SCPTSEL,@SCPTINFO
    74         Q
    75         ;
    76         ; **** May want to eventually combine TMDIS & TPDIS tags ****
    77         ;
    78 TMDIS(SCDATE,SCTEAM,SCNT,SCPTX) ; -- team unassignment for patient
    79         ; input:   SCDATE := effective date
    80         ;          SCTEAM := ien of TEAM entry (404.51)
    81         ;          SCNT   := entry in @SCPTINFO@ & @SCPTALL@ arrays
    82         ;          SCPTX  := format defined by output of $$PTTM^SCAPMC2
    83         ;
    84         N SCNODE,SCPOS,SCPOSI,SCOK,SCERRS,DFN,SCIEN,SCASDT,SCUNDT
    85         ;
    86         S SCOK=1
    87         S SCERRS="SCERRLST"
    88         ;
    89         S DFN=+SCPTX
    90         S SCIEN=+$P(SCPTX,U,3)
    91         S SCNODE=$NA(^SCPT(404.42,SCIEN,0))
    92         S SCASDT=+$P(SCPTX,U,4)
    93         S SCUNDT=+$P(SCPTX,U,5)
    94         ;
    95         ; -- unassign from positions first
    96         S SCPOS=0
    97         F  S SCPOS=$O(@SCPTTP@(DFN,SCPOS)) Q:'SCPOS  D  Q:'SCOK
    98         . S SCOK=$$TPDIS(SCDATE,SCPOS,SCNT,$G(@SCPTTP@(DFN,SCPOS)))
    99         ;
    100         IF 'SCOK D
    101         . S @SCERRAR@(SCNT,"TEAM",SCTEAM,1)="Team still assigned to patient."
    102         . S @SCERRAR@(SCNT,"TEAM",SCTEAM,2)="Not able to unassign at least one position."
    103         ;
    104         IF SCOK D
    105         . ; -- if assignment date is in future then delete
    106         . IF SCASDT>DT,SCASDT>SCDATE D  Q
    107         . . N DA,DIK
    108         . . S DA=SCIEN,DIK="^SCPT(404.42,"
    109         . . D LOCK(SCNODE)
    110         . . D ^DIK
    111         . . D UNLOCK(SCNODE)
    112         . . S @SCOKAR@(SCNT,"TEAM",SCTEAM,1)=">>> Future team assignment deleted."
    113         . . S @SCOKAR@(SCNT,"TEAM",SCTEAM,2)="    Assignment Date: "_$$FMTE^XLFDT(SCASDT,"5Z")_"   Entry#: "_SCIEN
    114         . . Q
    115         . ;
    116         . ; -- if assignment date is after effective date but before today
    117         . IF SCASDT>SCDATE,SCASDT<DT D  Q
    118         . . S SCOK=0
    119         . . S @SCERRAR@(SCNT,"TEAM",SCTEAM,1)="Patient is still assigned to team."
    120         . . S @SCERRAR@(SCNT,"TEAM",SCTEAM,2)="Assignment date is after effective date but before today."
    121         . . S @SCERRAR@(SCNT,"TEAM",SCTEAM,3)="Assignment Date: "_$$FMTE^XLFDT(SCASDT,"5Z")_"   Entry#: "_SCIEN
    122         . . Q
    123         . ;
    124         . ; -- if unassignment date is after effective date but before today
    125         . IF SCUNDT>SCDATE,SCUNDT<DT D  Q
    126         . . S SCOK=0
    127         . . S @SCERRAR@(SCNT,"TEAM",SCTEAM,1)="Patient is still assigned to team."
    128         . . S @SCERRAR@(SCNT,"TEAM",SCTEAM,2)="Unassignment date is after effective date but before today."
    129         . . S @SCERRAR@(SCNT,"TEAM",SCTEAM,3)="Unassignment Date: "_$$FMTE^XLFDT(SCUNDT,"5Z")_"   Entry#: "_SCIEN
    130         . . Q
    131         . ;
    132         . ; -- make change
    133         . K @SCERRS
    134         . S SCOK=$$INPTTM^SCAPMC(DFN,SCIEN,SCDATE,.SCERRS)
    135         . D UNLOCK(SCNODE)
    136         . M @SCERRAR@(SCNT,"TEAM",SCTEAM)=SCERRLST
    137         . K @SCERRS
    138         . IF SCOK D
    139         . . S @SCOKAR@(SCNT,"TEAM",SCTEAM,1)=""
    140         . ;
    141         . ; -- set message if unassigned date changed
    142         . IF SCOK,SCUNDT>SCDATE D
    143         . . S @SCOKAR@(SCNT,"TEAM",SCTEAM,1)=">>> Future team unassignment date was changed."
    144         . . S @SCOKAR@(SCNT,"TEAM",SCTEAM,2)="    Old Date: "_$$FMTE^XLFDT(SCUNDT,"5Z")_"   New Date: "_$$FMTE^XLFDT(SCDATE,"5Z")_"   Entry#: "_SCIEN_")"
    145         ;
    146         Q SCOK
    147         ;
    148 TPDIS(SCDATE,SCPOS,SCNT,SCPTX)  ; -- position unassignment for patient
    149         ; input:   SCDATE := effective date
    150         ;          SCTEAM := ien of TEAM POSITION entry (404.57)
    151         ;          SCNT   := entry in @SCPTINFO@ & @SCPTALL@ arrays
    152         ;          SCPTX  := format defined by output of $$PTTP^SCAPMC2
    153         ;
    154         N SCNODE,SCOK,SCERRS,DFN,SCIEN,SCASDT,SCUNDT
    155         S SCASDT=+$P(SCPTX,U,4)
    156         S SCUNDT=+$P(SCPTX,U,5)
    157         ;
    158         S SCOK=1
    159         S SCERRS="SCERRLST"
    160         ;
    161         S DFN=+SCPTX
    162         S SCIEN=+$P(SCPTX,U,3)
    163         S SCNODE=$NA(^SCPT(404.43,SCIEN,0))
    164         S SCASDT=+$P(SCPTX,U,4)
    165         S SCUNDT=+$P(SCPTX,U,5)
    166         ;
    167         ; if assignment date is in future then delete
    168         IF SCOK D
    169         . ; -- if assignment date is in future then delete
    170         . IF SCASDT>DT,SCASDT>SCDATE D  Q
    171         . . N DA,DIE,DIK,DR
    172         . . S DA=SCIEN,(DIE,DIK)="^SCPT(404.43,",DR=".04///"_DT D ^DIE  ; og/sd/524
    173         . . D LOCK(SCNODE)
    174         . . D ^DIK
    175         . . D UNLOCK(SCNODE)
    176         . . S @SCOKAR@(SCNT,"POS",SCPOS,1)="    >>> Future position assignment deleted."
    177         . . S @SCOKAR@(SCNT,"POS",SCPOS,2)="        Assignment Date: "_$$FMTE^XLFDT(SCASDT,"5Z")_"   Entry#: "_SCIEN
    178         . . Q
    179         . ;
    180         . ; -- if assignment date is after effective date but before today
    181         . IF SCASDT>SCDATE,SCASDT<DT D  Q
    182         . . S SCOK=0
    183         . . S @SCERRAR@(SCNT,"POS",SCPOS,1)="Patient is still assigned to position."
    184         . . S @SCERRAR@(SCNT,"POS",SCPOS,2)="Assignment date is after effective date but before today."
    185         . . S @SCERRAR@(SCNT,"POS",SCPOS,3)="Assignment Date: "_$$FMTE^XLFDT(SCASDT,"5Z")_"   Entry#: "_SCIEN
    186         . . Q
    187         . ;
    188         . ; -- if unassignment date is after effective date but before today
    189         . IF SCUNDT>SCDATE,SCUNDT<DT D  Q
    190         . . S SCOK=0
    191         . . S @SCERRAR@(SCNT,"POS",SCPOS,1)="Patient is still assigned to position."
    192         . . S @SCERRAR@(SCNT,"POS",SCPOS,2)="Unassignment date is after effective date but before today."
    193         . . S @SCERRAR@(SCNT,"POS",SCPOS,3)="Unassignment Date: "_$$FMTE^XLFDT(SCUNDT,"5Z")_" ("_SCIEN_")"
    194         . . Q
    195         . ;
    196         . K @SCERRS
    197         . D LOCK(SCNODE)
    198         . S SCOK=$$INPTTP^SCAPMC(DFN,SCIEN,SCDATE,.SCERRS)
    199         . D UNLOCK(SCNODE)
    200         . M @SCERRAR@(SCNT,"POS",SCPOS)=SCERRLST
    201         . K @SCERRS
    202         . IF SCOK D
    203         . . S @SCOKAR@(SCNT,"POS",SCPOS,1)=""
    204         . ;
    205         . ; -- set message if unassigned date changed
    206         . IF SCOK,SCUNDT>SCDATE D
    207         . . S @SCOKAR@(SCNT,"POS",SCPOS,1)="    >>> Future position unassignment date was changed."
    208         . . S @SCOKAR@(SCNT,"POS",SCPOS,2)="        Old Date: "_$$FMTE^XLFDT(SCUNDT,"5Z")_"   New Date: "_$$FMTE^XLFDT(SCDATE,"5Z")_"   Entry#: "_SCIEN_")"
    209         . . Q
    210         ;
    211         IF SCOK D
    212         . S @SCOKAR@(SCNT,"CLINIC",SCPOS,1)=$$CLDIS(SCPOS)
    213         . Q
    214         ;
    215 TPDISQ  Q SCOK
    216         ;
    217 CLDIS(SCPOS)    ; -- discharge from clinic
    218         N SCPOS0,SCCLN,SCREA,SCRET
    219         S SCRET=""
    220         ;
    221         ; -- if user did not request clinic discharge, quit
    222         IF '$G(SCTPDIS(+SCPOS)) G CLDISQ
    223         ;
    224         S SCPOS0=$G(^SCTM(404.57,SCPOS,0))
    225         S SCCLN=$P(SCPOS0,U,9)
    226         IF SCCLN D
    227         . S SCREA="Team position mass discharge"
    228         . S SCRET=$$EN^SCMCMU3(DFN,SCCLN,SCDATE,SCREA)
    229         . Q
    230         ELSE  D
    231         . S SCRET="0^No clinic assignment to position"
    232         . Q
    233         ;
    234 CLDISQ  Q SCRET
    235         ;
    236 LOCK(NODE)      ; -- lock node
    237         F  L +@NODE:5 IF $T Q
    238         Q
    239         ;
    240 UNLOCK(NODE)    ; -- unlock node
    241         L -@NODE
    242         Q
    243         ;
     1SCMCMU2 ;ALB/MJK - PCMM Mass Team/Position Unassignment Processing ; 10-JUL-1998
     2 ;;5.3;Scheduling;**148,177**;AUG 13, 1993
     3 ;
     4QUE() ; -- queue mass unassignment
     5 ;D START Q 99999 ; -- for interactive testing
     6 N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSAVE,ZTSK
     7 S ZTRTN="START^SCMCMU2"
     8 S ZTDESC=VALM("TITLE")
     9 S ZTDTH=$H
     10 S ZTIO=""
     11 F X="SCTEAM","SCPOS","SCTPDIS(","SCMUTYPE","SCDATE","SCSELCNT" S ZTSAVE(X)=""
     12 F X="^TMP(""SCMU"",$J,""SELECTED"",","^TMP(""SCMU"",$J,""PATIENT INFO""," S ZTSAVE(X)=""
     13 D ^%ZTLOAD
     14 Q $G(ZTSK)
     15 ;
     16START ; -- entry point for task
     17 ; -- defined from task SCTEAM,SCPOS,SCTPDIS,SCMUTYPE,SCDATE,SCSELCNT
     18 ;
     19 N SCTOP,SCUNCNT,SCASCNT,SCOK
     20 S SCUNCNT=0
     21 S SCASCNT=SCSELCNT
     22 ;
     23 ; -- lock top node
     24 IF SCMUTYPE="T" D
     25 . S SCTOP=$NA(^SCTM(404.51,+SCTEAM,0))
     26 ELSE  IF SCMUTYPE="P" D
     27 . S SCTOP=$NA(^SCTM(404.57,+SCPOS,0))
     28 D LOCK(SCTOP)
     29 ;
     30 ; -- use tmp data brought in by TaskMan
     31 N SCPTSEL,SCPTINFO
     32 S SCPTSEL=$NA(^TMP("SCMU",$J,"SELECTED"))
     33 S SCPTINFO=$NA(^TMP("SCMU",$J,"PATIENT INFO"))
     34 ;
     35 N SCOKAR,SCBADAR,SCERRAR,SCPTTP
     36 S SCOKAR=$NA(^TMP("SCMU",$J,"OK"))
     37 S SCBADAR=$NA(^TMP("SCMU",$J,"BAD"))
     38 S SCERRAR=$NA(^TMP("SCMU",$J,"ERROR"))
     39 S SCPTTP=$NA(^TMP("SCMU",$J,"PATIENT-POSITION"))
     40 K @SCOKAR,@SCBADAR,@SCERRAR,@SCPTTP
     41 ;
     42 N SCNT,SCNODE,SCPTX
     43 ;
     44 ; -- create patient-position array for team processing
     45 IF SCMUTYPE="T" D PTTPLST^SCMCMU11(SCTEAM,SCDATE,SCPTTP)
     46 ;
     47 S SCNT=0
     48 F  S SCNT=$O(@SCPTSEL@(SCNT)) Q:'SCNT  D
     49 . ;N SCDATE S SCDATE=2700101 ; -- use to force error/testing
     50 . S SCPTX=$G(@SCPTINFO@(SCNT))
     51 . IF SCPTX="" Q
     52 . IF SCMUTYPE="T" S SCOK=$$TMDIS(SCDATE,SCTEAM,SCNT,SCPTX)
     53 . ;
     54 . IF SCMUTYPE="P" S SCOK=$$TPDIS(SCDATE,SCPOS,SCNT,SCPTX)
     55 . ;
     56 . ; -- if successful
     57 . IF SCOK D
     58 . . S @SCOKAR@(SCNT)=""
     59 . . S SCUNCNT=SCUNCNT+1
     60 . . S SCASCNT=SCASCNT-1
     61 . ;
     62 . ; -- if not sucessful
     63 . ELSE  D
     64 . . S @SCBADAR@(SCNT)=""
     65 ;
     66 ; -- unlock top node
     67 D UNLOCK(SCTOP)
     68 ;
     69 ; -- send results
     70 D BULL^SCMCMU4
     71 ;
     72 K @SCOKAR,@SCBADAR,@SCERRAR,@SCPTTP
     73 K @SCPTSEL,@SCPTINFO
     74 Q
     75 ;
     76 ; **** May want to eventually combine TMDIS & TPDIS tags ****
     77 ;
     78TMDIS(SCDATE,SCTEAM,SCNT,SCPTX) ; -- team unassignment for patient
     79 ; input:   SCDATE := effective date
     80 ;          SCTEAM := ien of TEAM entry (404.51)
     81 ;          SCNT   := entry in @SCPTINFO@ & @SCPTALL@ arrays
     82 ;          SCPTX  := format defined by output of $$PTTM^SCAPMC2
     83 ;
     84 N SCNODE,SCPOS,SCPOSI,SCOK,SCERRS,DFN,SCIEN,SCASDT,SCUNDT
     85 ;
     86 S SCOK=1
     87 S SCERRS="SCERRLST"
     88 ;
     89 S DFN=+SCPTX
     90 S SCIEN=+$P(SCPTX,U,3)
     91 S SCNODE=$NA(^SCPT(404.42,SCIEN,0))
     92 S SCASDT=+$P(SCPTX,U,4)
     93 S SCUNDT=+$P(SCPTX,U,5)
     94 ;
     95 ; -- unassign from positions first
     96 S SCPOS=0
     97 F  S SCPOS=$O(@SCPTTP@(DFN,SCPOS)) Q:'SCPOS  D  Q:'SCOK
     98 . S SCOK=$$TPDIS(SCDATE,SCPOS,SCNT,$G(@SCPTTP@(DFN,SCPOS)))
     99 ;
     100 IF 'SCOK D
     101 . S @SCERRAR@(SCNT,"TEAM",SCTEAM,1)="Team still assigned to patient."
     102 . S @SCERRAR@(SCNT,"TEAM",SCTEAM,2)="Not able to unassign at least one position."
     103 ;
     104 IF SCOK D
     105 . ; -- if assignment date is in future then delete
     106 . IF SCASDT>DT,SCASDT>SCDATE D  Q
     107 . . N DA,DIK
     108 . . S DA=SCIEN,DIK="^SCPT(404.42,"
     109 . . D LOCK(SCNODE)
     110 . . D ^DIK
     111 . . D UNLOCK(SCNODE)
     112 . . S @SCOKAR@(SCNT,"TEAM",SCTEAM,1)=">>> Future team assignment deleted."
     113 . . S @SCOKAR@(SCNT,"TEAM",SCTEAM,2)="    Assignment Date: "_$$FMTE^XLFDT(SCASDT,"5Z")_"   Entry#: "_SCIEN
     114 . . Q
     115 . ;
     116 . ; -- if assignment date is after effective date but before today
     117 . IF SCASDT>SCDATE,SCASDT<DT D  Q
     118 . . S SCOK=0
     119 . . S @SCERRAR@(SCNT,"TEAM",SCTEAM,1)="Patient is still assigned to team."
     120 . . S @SCERRAR@(SCNT,"TEAM",SCTEAM,2)="Assignment date is after effective date but before today."
     121 . . S @SCERRAR@(SCNT,"TEAM",SCTEAM,3)="Assignment Date: "_$$FMTE^XLFDT(SCASDT,"5Z")_"   Entry#: "_SCIEN
     122 . . Q
     123 . ;
     124 . ; -- if unassignment date is after effective date but before today
     125 . IF SCUNDT>SCDATE,SCUNDT<DT D  Q
     126 . . S SCOK=0
     127 . . S @SCERRAR@(SCNT,"TEAM",SCTEAM,1)="Patient is still assigned to team."
     128 . . S @SCERRAR@(SCNT,"TEAM",SCTEAM,2)="Unassignment date is after effective date but before today."
     129 . . S @SCERRAR@(SCNT,"TEAM",SCTEAM,3)="Unassignment Date: "_$$FMTE^XLFDT(SCUNDT,"5Z")_"   Entry#: "_SCIEN
     130 . . Q
     131 . ;
     132 . ; -- make change
     133 . K @SCERRS
     134 . S SCOK=$$INPTTM^SCAPMC(DFN,SCIEN,SCDATE,.SCERRS)
     135 . D UNLOCK(SCNODE)
     136 . M @SCERRAR@(SCNT,"TEAM",SCTEAM)=SCERRLST
     137 . K @SCERRS
     138 . IF SCOK D
     139 . . S @SCOKAR@(SCNT,"TEAM",SCTEAM,1)=""
     140 . ;
     141 . ; -- set message if unassigned date changed
     142 . IF SCOK,SCUNDT>SCDATE D
     143 . . S @SCOKAR@(SCNT,"TEAM",SCTEAM,1)=">>> Future team unassignment date was changed."
     144 . . S @SCOKAR@(SCNT,"TEAM",SCTEAM,2)="    Old Date: "_$$FMTE^XLFDT(SCUNDT,"5Z")_"   New Date: "_$$FMTE^XLFDT(SCDATE,"5Z")_"   Entry#: "_SCIEN_")"
     145 ;
     146 Q SCOK
     147 ;
     148TPDIS(SCDATE,SCPOS,SCNT,SCPTX) ; -- position unassignment for patient
     149 ; input:   SCDATE := effective date
     150 ;          SCTEAM := ien of TEAM POSITION entry (404.57)
     151 ;          SCNT   := entry in @SCPTINFO@ & @SCPTALL@ arrays
     152 ;          SCPTX  := format defined by output of $$PTTP^SCAPMC2
     153 ;
     154 N SCNODE,SCOK,SCERRS,DFN,SCIEN,SCASDT,SCUNDT
     155 S SCASDT=+$P(SCPTX,U,4)
     156 S SCUNDT=+$P(SCPTX,U,5)
     157 ;
     158 S SCOK=1
     159 S SCERRS="SCERRLST"
     160 ;
     161 S DFN=+SCPTX
     162 S SCIEN=+$P(SCPTX,U,3)
     163 S SCNODE=$NA(^SCPT(404.43,SCIEN,0))
     164 S SCASDT=+$P(SCPTX,U,4)
     165 S SCUNDT=+$P(SCPTX,U,5)
     166 ;
     167 ; if assignment date is in future then delete
     168 IF SCOK D
     169 . ; -- if assignment date is in future then delete
     170 . IF SCASDT>DT,SCASDT>SCDATE D  Q
     171 . . N DA,DIK
     172 . . S DA=SCIEN,DIK="^SCPT(404.43,"
     173 . . D LOCK(SCNODE)
     174 . . D ^DIK
     175 . . D UNLOCK(SCNODE)
     176 . . S @SCOKAR@(SCNT,"POS",SCPOS,1)="    >>> Future position assignment deleted."
     177 . . S @SCOKAR@(SCNT,"POS",SCPOS,2)="        Assignment Date: "_$$FMTE^XLFDT(SCASDT,"5Z")_"   Entry#: "_SCIEN
     178 . . Q
     179 . ;
     180 . ; -- if assignment date is after effective date but before today
     181 . IF SCASDT>SCDATE,SCASDT<DT D  Q
     182 . . S SCOK=0
     183 . . S @SCERRAR@(SCNT,"POS",SCPOS,1)="Patient is still assigned to position."
     184 . . S @SCERRAR@(SCNT,"POS",SCPOS,2)="Assignment date is after effective date but before today."
     185 . . S @SCERRAR@(SCNT,"POS",SCPOS,3)="Assignment Date: "_$$FMTE^XLFDT(SCASDT,"5Z")_"   Entry#: "_SCIEN
     186 . . Q
     187 . ;
     188 . ; -- if unassignment date is after effective date but before today
     189 . IF SCUNDT>SCDATE,SCUNDT<DT D  Q
     190 . . S SCOK=0
     191 . . S @SCERRAR@(SCNT,"POS",SCPOS,1)="Patient is still assigned to position."
     192 . . S @SCERRAR@(SCNT,"POS",SCPOS,2)="Unassignment date is after effective date but before today."
     193 . . S @SCERRAR@(SCNT,"POS",SCPOS,3)="Unassignment Date: "_$$FMTE^XLFDT(SCUNDT,"5Z")_" ("_SCIEN_")"
     194 . . Q
     195 . ;
     196 . K @SCERRS
     197 . D LOCK(SCNODE)
     198 . S SCOK=$$INPTTP^SCAPMC(DFN,SCIEN,SCDATE,.SCERRS)
     199 . D UNLOCK(SCNODE)
     200 . M @SCERRAR@(SCNT,"POS",SCPOS)=SCERRLST
     201 . K @SCERRS
     202 . IF SCOK D
     203 . . S @SCOKAR@(SCNT,"POS",SCPOS,1)=""
     204 . ;
     205 . ; -- set message if unassigned date changed
     206 . IF SCOK,SCUNDT>SCDATE D
     207 . . S @SCOKAR@(SCNT,"POS",SCPOS,1)="    >>> Future position unassignment date was changed."
     208 . . S @SCOKAR@(SCNT,"POS",SCPOS,2)="        Old Date: "_$$FMTE^XLFDT(SCUNDT,"5Z")_"   New Date: "_$$FMTE^XLFDT(SCDATE,"5Z")_"   Entry#: "_SCIEN_")"
     209 . . Q
     210 ;
     211 IF SCOK D
     212 . S @SCOKAR@(SCNT,"CLINIC",SCPOS,1)=$$CLDIS(SCPOS)
     213 . Q
     214 ;
     215TPDISQ Q SCOK
     216 ;
     217CLDIS(SCPOS) ; -- discharge from clinic
     218 N SCPOS0,SCCLN,SCREA,SCRET
     219 S SCRET=""
     220 ;
     221 ; -- if user did not request clinic discharge, quit
     222 IF '$G(SCTPDIS(+SCPOS)) G CLDISQ
     223 ;
     224 S SCPOS0=$G(^SCTM(404.57,SCPOS,0))
     225 S SCCLN=$P(SCPOS0,U,9)
     226 IF SCCLN D
     227 . S SCREA="Team position mass discharge"
     228 . S SCRET=$$EN^SCMCMU3(DFN,SCCLN,SCDATE,SCREA)
     229 . Q
     230 ELSE  D
     231 . S SCRET="0^No clinic assignment to position"
     232 . Q
     233 ;
     234CLDISQ Q SCRET
     235 ;
     236LOCK(NODE) ; -- lock node
     237 F  L +@NODE:5 IF $T Q
     238 Q
     239 ;
     240UNLOCK(NODE) ; -- unlock node
     241 L -@NODE
     242 Q
     243 ;

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCQK1.m

    r613 r623  
    1 SCMCQK1 ;ALBOI/REW - Single Pt Tm/Pt Tm Pos Assign and Discharge;11/07/02
    2         ;;5.3;Scheduling;**148,177,231,264,436,297,446,524**;AUG 13, 1993;Build 29
    3         ;
    4         ;04/25/2006 SD*5.3*446 INTER-FACILITY TRANSFER
    5 UNTP    ;unassign patient from pc prac position
    6         I '$G(SCTP) W !,"No position defined" Q
    7         N OK,SCER,SCCL,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS
    8         S OK=0
    9         W !,"About to Unassign "_$$NAME(DFN)_" from: ",!,?8,$$POSITION(SCTP)_" position   ["_$P($$GETPRTP^SCAPMCU2(SCTP,DT),U,2)_"]"
    10         S SCDISCH=$$DATE("D")
    11         G:SCDISCH<1 QTUNTP
    12         G:'$$CONFIRM() QTUNTP
    13         S OK=$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER)  ; og/sd/524
    14         G:OK'>0 QTUNTP
    15         S SCCL=$P($G(^SCTM(404.57,+$G(SCTP),0)),U,9)
    16         I SCCL D DISCL
    17 QTUNTP  W !,"Position Unassignment "_$S(OK:"made.",1:"NOT made.")
    18         Q
    19 ENRCL   ;
    20         N SCRESTA,SCREST,SCCLNM,SCTM
    21         N SCCL
    22         F SCCL=0:0 S SCCL=$O(^SCTM(404.57,+$G(SCTP),5,SCCL)) Q:'SCCL  D
    23         .Q:$$ACTCL(DFN,SCCL)
    24         .W !!!,"The "_$$POSITION(SCTP)_" is associated with the ",$$CLINIC(SCCL)_" clinic."
    25         .;SCRESTA = Array of pt's teams causing restricted consults
    26         .N SCRESTA
    27         .S SCREST=$$RESTPT^SCAPMCU4(DFN,DT,"SCRESTA")
    28         .I SCREST D
    29         ..N SCTM
    30         ..S SCCLNM=Y
    31         ..W !,?5,"Patient has restricted consults due to team assignment(s):"
    32         ..S SCTM=0
    33         ..F  S SCTM=$O(SCRESTA(SCTM)) Q:'SCTM  W !,?10,SCRESTA(SCTM)
    34         .I SCREST&'$G(SCOKCONS) D  G QTECL
    35         ..W !,?5,"This patient may only be enrolled in clinics via"
    36         ..W !,?15,"Edit Clinic Enrollment Data option"
    37         .W !,"Do you wish to enroll the patient from this clinic on "
    38         .S Y=SCASSDT X ^DD("DD") W Y,"?"
    39         .I $$YESNO() D
    40         ..W !,"Clinic Enrollment"
    41         ..I $$ACPTCL^SCAPMC18(DFN,SCCL,,SCASSDT,"SCENER") W " made"
    42         ..E  W "NOT made"
    43 QTECL   Q
    44 DISCL   ;
    45         N SCCL F SCCL=0:0 S SCCL=$O(^SCTM(404.57,+$G(SCTP),5,SCCL)) Q:'SCCL  D
    46         .Q:'$$ACTCL(DFN,SCCL)
    47         .W !,$$NAME(DFN)," is enrolled in the associated "_$$CLINIC(SCCL)_" clinic."
    48         .W !,"Do you wish to discharge the patient from this clinic on "
    49         .S Y=SCDISCH X ^DD("DD") W Y,"?"
    50         .Q:'$$YESNO()
    51         .N SDFN,SDCLN S SDFN=DFN,SDCLN=SCCL
    52         .N DFN D ^SDCD
    53 QTDCL   Q
    54 UNTM    ;
    55         ;assign patient from pc team (and pc position if possible)
    56         N OK,SCER,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS,OK2,OK3
    57         S OK=0
    58         W !!,"About to Unassign "_$$NAME(DFN)_" from "_$$TEAMNM(SCTM)_" team"
    59         W:'SCTPSTAT !,?5,"AND from "_$$POSITION(SCTP)_" position  ["_$$WRITETP^SCMCDD1(SCTP)_"]"
    60         S SCDISCH=$$DATE("D")
    61         G:SCDISCH<1 QTUNTM
    62         G:'$$CONFIRM() QTUNTM
    63         IF 'SCTPSTAT D  G:OK2'>0 QTUNTM
    64         .W !,"PC assignment unassigned."
    65         .S OK2=$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER)
    66         .IF OK2>0 D
    67         ..W "made."
    68         ..S SCCL=$P(^SCTM(404.57,SCTP,0),U,9)
    69         ..D:SCCL DISCL
    70         S OK3=$$ALLPOS()
    71         IF $$OKINPTTM^SCMCTMU2(DFN,SCTM,SCDISCH) D
    72         .S OK=$$INPTSCTM^SCAPMC7(DFN,SCTM,SCDISCH,.SCER)
    73         ELSE  D
    74         .W !,"Future/Current Patient-Position Assignment exists"
    75 QTUNTM  W !,"Team Unassignment "_$S(OK:"made",1:"NOT made.")
    76         Q
    77 ALLPOS()        ;unassign all patient-positions for team
    78         ;not stand-alone - needs dfn,sctm
    79         ;return 1=No positions left assigned|0=At least 1 position assigned
    80         N OK,SCDT1,SCPTTPX,SCERRR,SCTP,SCCNT,SCPTTPI,SCLOC,SCNODE,SCPTTP2
    81         S SCDT1("BEGIN")=SCDISCH+1
    82         S SCDT1("END")=3990101
    83         S SCDT1("INCL")=0  ;anytime from now to future
    84         S OK=$$TPPT^SCAPMC23(DFN,"SCDT1",,,,,,"SCPTTPX",.SCERRR)
    85         S (SCTP,SCCNT)=0
    86         W !,"Checking for other position assignments to team..."
    87         F  S SCTP=$O(SCPTTPX("SCTP",SCTM,SCTP)) Q:'SCTP  S SCCNT=SCCNT+1 D
    88         .S SCPTTPI=$O(SCPTTPX("SCTP",SCTM,SCTP,9999999),-1)
    89         .S SCLOC=$O(SCPTTPX("SCTP",SCTM,SCTP,SCPTTPI,0))
    90         .S SCNODE=SCPTTPX(SCLOC)
    91         .S SCPTTP2(SCTP)=""
    92         .W !,?3,$P(SCNODE,U,2),"   ",$P(SCNODE,U,8)
    93         .IF $P(SCNODE,U,6)!(SCDISCH'>$P(SCNODE,U,5)) D
    94         ..W !,?5,"Unassignment date already exists or unassignment after assignment date"
    95         ..W !,?15,"- Correct via PCMM GUI"
    96         ..S OK=0
    97         W !,?5,$S(SCCNT:SCCNT,1:"No")_" current/future position assignment(s)"
    98         G:'OK!('SCCNT) QTALL
    99         W !!,"About to unassign the above patient-position assignments"
    100         IF '$$CONFIRM S OK=0 G QTALL
    101         S SCTP=0
    102         F  S SCTP=$O(SCPTTP2(SCTP)) Q:'SCTP  D  Q:'OK
    103         .S OK=$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER)
    104         .W:'OK !,?10,"Problem with unassignment, correct via PCMM GUI"
    105 QTALL   Q OK
    106 ASTM    ;assign patient to PC team
    107         N DIC,Y,OK,SCTM,SCTMFLDS,SCER,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS
    108         S OK=0
    109         W !!,"About to Assign "_$$NAME(DFN)_" to a primary care team"
    110         I $$SC(DFN) W !!,"********** This patient is 50 percent or greater service-connected ************"
    111         S DIC="^SCTM(404.51,"
    112         S DIC(0)="AEMQZ"
    113         S DIC("S")="IF $$ACTTM^SCMCTMU(Y,DT)&($P($G(^SCTM(404.51,Y,0)),U,5))"
    114         ;select from active teams that can be PC Teams
    115         D ^DIC
    116         G:Y<1 QTASTM
    117         S SCTM=+Y
    118         ;The following logic to present warning message added per SD*5.3*436
    119         I $P($G(^SCTM(404.51,SCTM,0)),U,10) D  G:'SCFLAG QTASTM
    120         .S SCFLAG=0
    121         .W !!,"This team is closed to further patient assignments.  While you are"
    122         .W !,"not currently prevented from assigning this patient, you may want to"
    123         .W !,"check before continuing."
    124         .Q:'$$YESNO1()  ; new function call per SD*5.3*436
    125         .Q:'$$CONFIRM()
    126         .S SCFLAG=1 W !
    127         S SCASSDT=$$DATE("A")
    128         G:SCASSDT<1 QTASTM
    129         S SCTMCT=$$TEAMCNT^SCAPMCU1(SCTM)
    130         S SCTMMAX=$P($$GETEAM^SCAPMCU3(SCTM),"^",8)
    131         I SCTMCT'<SCTMMAX  D  G QTASTM:$$WAITYN(),QTASTM:'$$YESNO2()
    132         .W !,"This assignment will reach or exceeded the maximum set for this team."
    133         .W !,"Currently assigned: "_SCTMCT
    134         .W !,"Maximum set for team: "_SCTMMAX
    135         I SCTMCT<SCTMMAX,'$$CONFIRM() G QTASTM
    136         S SCTM=+Y
    137         ;setup fields
    138         S SCTMFLDS(.08)=1 ;primary care assignment
    139         S SCTMFLDS(.11)=$G(DUZ,.5)
    140         D NOW^%DTC S SCTMFLDS(.12)=%
    141         IF $$ACPTTM^SCAPMC(DFN,SCTM,"SCTMFLDS",SCASSDT,"SCTPTME") D
    142         .S SCSELECT=$$SELPOS()
    143         .D:$L(SCSELECT) ASTP ;prompt for position prompt
    144         .S OK=1
    145 QTASTM  W !,"Team Assignment "_$S(OK:"made",1:"NOT made.")
    146         S:$D(SDWLPCMM) SDWLPCMM=OK  ; 446
    147         Q
    148 ASTP    ;assign patient to PC practitioner
    149         N DIC,Y,OK,SCCL,X,SCTPFLDS,SCER,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS
    150         S OK=0
    151         W !!,"About to Assign "_$$NAME(DFN)_" to PC Position Assignment"
    152         I $$SC(DFN) W !!,"********** This patient is 50 percent or greater service-connected ************"
    153         ;lookup to display only position and [practitioner]
    154         IF SCSELECT="PRACT" D
    155         .S DIC("W")="N SCP1 S SCP1=$G(^SCTM(404.52,Y,0)) W ""    ["",$P($G(^VA(200,+$P(SCP1,U,3),0)),U,1),""]"""
    156         .S DIC("A")="POSITION's Current PRACTITIONER: "
    157         .S DIC="^SCTM(404.52,"
    158         .;Must be from team, must be activation,must not have future inactivation
    159         .S DIC("S")="I $$PRACSCR^SCMCQK1(Y)"
    160         .S D="C"
    161         ELSE  D
    162         .S DIC="^SCTM(404.57,"
    163         .S D="B"
    164         .S DIC("A")="POSITION's Name: "
    165         .S DIC("S")="I $$POSSCR^SCMCQK1(Y)"
    166         S DIC(0)="AEMQZ"
    167         D MIX^DIC1
    168         G:Y<1 QTASTP
    169         IF SCSELECT="PRACT" D
    170         .S SCTP=$P(Y,U,2)
    171         ELSE  D
    172         .S SCTP=$P(Y,U,1)
    173         S SCASSDT=$$DATE("A")
    174         G:SCASSDT<1 QTASTP
    175         S SCTMCT=$$PCPOSCNT^SCAPMCU1(SCTP),SCTMMAX=+$P($G(^SCTM(404.57,SCTP,0)),U,8)
    176         I SCTMCT'<SCTMMAX D  G QTASTP:$$WAITYN,QTASTP:'$$YESNO2
    177         .W !,"This assignment will reach or exceeded the maximum set for this position."
    178         .W !,"Currently assigned: "_SCTMCT
    179         .W !,"Maximum set for position: "_SCTMMAX
    180         G:'$$CONFIRM() QTASTP
    181         ;setup fields
    182         S SCTPFLDS(.03)=SCASSDT
    183         S SCTPFLDS(.05)=1 ;pc pract role
    184         S SCTPFLDS(.06)=$G(DUZ,.5)
    185         D NOW^%DTC S SCTPFLDS(.07)=%
    186         IF $$ACPTTP^SCAPMC21(DFN,SCTP,"SCTPFLDS",SCASSDT,"SCTPTME",0) D
    187         .S OK=1
    188         .S SCCL=$O(^SCTM(404.57,+$G(SCTP),5,0))
    189         .D:SCCL ENRCL
    190 QTASTP  W !,"Position Assignment "_$S(OK:"made",1:"NOT made.")
    191         S:$D(SDWLPCMM) SDWLPCMM=OK ;446
    192         Q
    193 NAME(DFN)       ;return patient name
    194         Q $P($G(^DPT(DFN,0)),U,1)
    195 POSITION(SCTP)  ;return position name
    196         Q $P($G(^SCTM(404.57,SCTP,0)),U,1)
    197 TEAMNM(SCTM)    ;return team name
    198         Q $P($G(^SCTM(404.51,SCTM,0)),U,1)
    199 CLINIC(SCCL)    ;return clinic name
    200         Q $P($G(^SC(+SCCL,0)),U,1)
    201 YESNO() ;
    202         N DIR,X,Y
    203         S DIR(0)="Y",DIR("B")="YES"
    204         D ^DIR
    205         Q Y>0
    206 YESNO1()        ; added per SD*5.3*436
    207         N DIR,X,Y
    208         S DIR(0)="Y",DIR("A")="Do you wish to assign this patient now (Yes/No)?"
    209         S DIR("B")="NO"
    210         D ^DIR
    211         Q Y>0
    212 YESNO2()        ;
    213         N DIR,X,Y
    214         S DIR(0)="Y",DIR("B")="NO"
    215         S DIR("A")="Do you wish to continue with the assignment (Yes/No)?"
    216         D ^DIR
    217         Q Y>0
    218 CONFIRM()       ;confirmation call
    219         N DIR,X,Y
    220         S DIR("A")="Are you sure (Yes/No)"
    221         S DIR(0)="Y"
    222         D ^DIR
    223         Q +Y=1
    224 SELPOS()        ;return way to select position: 1=PRACT,2=POSIT,3=NONE
    225         N DIR,X,Y
    226         W !,"Choose way to select PC POSITION Assignment: "
    227         S DIR(0)="SO^0:NONE;1:BY PRACTITIONER ASSIGNMENT;2:BY POSITION ASSIGNMENT"
    228         S DIR("B")=1
    229         D ^DIR
    230         Q $S(Y'>0:"",+Y=1:"PRACT",1:"POSIT")
    231 DATE(TYPE)      ;return date type=A or D
    232         N DIR,X,Y
    233         S DIR("A")=$S(TYPE="A":"Assignment",1:"Unassignment")_" date: "
    234         S DIR(0)="DA^::EXP"
    235         S Y=$S($D(SCDISCH):SCDISCH,$D(SCASSDT):SCASSDT,(TYPE="A"):"TODAY",1:"TODAY-1")
    236         X ^DD("DD")
    237         S DIR("B")=Y
    238         D ^DIR
    239         Q Y
    240 ACTCL(DFN,SCCL) ;is patient enrolled in clinic?
    241         N SCXX
    242         S SCXX=$O(^DPT(DFN,"DE","B",SCCL,9999),-1)
    243         Q $S('SCXX:0,($P(^DPT(DFN,"DE",+SCXX,0),U,2)="I"):0,1:1)
    244 PRACSCR(SC40452)        ;screen for for file 404.52
    245         N SCP,SCNODE,OK
    246         S SCP=$G(^SCTM(404.52,SC40452,0))
    247         S OK=0
    248         G:'SCP QTPP
    249         S SCNODE=$G(^SCTM(404.57,+SCP,0))
    250         S OK=$S($P(SCNODE,U,2)'=SCTM:0,'$P(SCNODE,U,4):0,($O(^SCTM(404.52,"AIDT",+SCP,1,""))'=-$P(SCP,U,2)):0,($O(^SCTM(404.52,"AIDT",+SCP,0,-$P(SCP,U,2)),-1)):0,($$ACTTP^SCMCTPU(+SCP)>0):1,1:0)
    251 QTPP    Q OK
    252 POSSCR(SCTP)    ;screen for file 404.57
    253         N SCNODE
    254         S SCNODE=$G(^SCTM(404.57,SCTP,0))
    255         Q $S($P(SCNODE,U,2)'=SCTM:0,'$P(SCNODE,U,4):0,($$ACTTP^SCMCTPU(SCTP)>0):1,1:0)
    256         Q
    257 WAITYN()        ;
    258         N %,OK,Y
    259         I SCTMCT<SCTMMAX Q 0
    260         N A,SC S A=$$ONWAIT^SCMCWAIT(DFN) I A W:(+A=3) !,$P(A,";",2) I $S($G(SCTP):A>1,1:1) Q 0
    261         N DIR,X,Y
    262         S DIR(0)="Y",DIR("B")="NO"
    263         S DIR("A")="Do you wish to place the patient on the wait list (Yes/No)?"
    264         D ^DIR
    265         I Y=1 S Y=$$WAITS^SCMCWAIT(DFN,SCTM,$G(SCTP),$G(SC)) I Y>0 W !,"Patient Placed on Wait List"
    266         Q Y>0
    267 SC(DFN) ;Is patient 50 to 100%
    268         D ELIG^VADPT Q $P($G(VAEL(3)),U,2)>49
     1SCMCQK1 ;ALB/REW - Single Pt Tm/Pt Tm Pos Assign and Discharge ; 07 Oct 2002  12:10 PM  ; Compiled April 12, 2007 10:03:59
     2 ;;5.3;Scheduling;**148,177,231,264,436,297,446**;AUG 13, 1993;Build 77
     3 ;
     4 ;04/25/2006 SD*5.3*446 INTER-FACILITY TRANSFER
     5UNTP ;unassign patient from pc prac position
     6 I '$G(SCTP) W !,"No position defined" Q
     7 N OK,SCER,SCCL,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS
     8 S OK=0
     9 W !,"About to Unassign "_$$NAME(DFN)_" from: ",!,?8,$$POSITION(SCTP)_" position   ["_$P($$GETPRTP^SCAPMCU2(SCTP,DT),U,2)_"]"
     10 S SCDISCH=$$DATE("D")
     11 G:SCDISCH<1 QTUNTP
     12 G:'$$CONFIRM() QTUNTP
     13 S OK=1 ;$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER)
     14 G:OK'>0 QTUNTP
     15 S SCCL=$P($G(^SCTM(404.57,+$G(SCTP),0)),U,9)
     16 I SCCL D DISCL
     17QTUNTP W !,"Position Unassignment "_$S(OK:"made.",1:"NOT made.")
     18 Q
     19ENRCL ;
     20 N SCRESTA,SCREST,SCCLNM,SCTM
     21 N SCCL
     22 F SCCL=0:0 S SCCL=$O(^SCTM(404.57,+$G(SCTP),5,SCCL)) Q:'SCCL  D
     23 .Q:$$ACTCL(DFN,SCCL)
     24 .W !!!,"The "_$$POSITION(SCTP)_" is associated with the ",$$CLINIC(SCCL)_" clinic."
     25 .;SCRESTA = Array of pt's teams causing restricted consults
     26 .N SCRESTA
     27 .S SCREST=$$RESTPT^SCAPMCU4(DFN,DT,"SCRESTA")
     28 .I SCREST D
     29 ..N SCTM
     30 ..S SCCLNM=Y
     31 ..W !,?5,"Patient has restricted consults due to team assignment(s):"
     32 ..S SCTM=0
     33 ..F  S SCTM=$O(SCRESTA(SCTM)) Q:'SCTM  W !,?10,SCRESTA(SCTM)
     34 .I SCREST&'$G(SCOKCONS) D  G QTECL
     35 ..W !,?5,"This patient may only be enrolled in clinics via"
     36 ..W !,?15,"Edit Clinic Enrollment Data option"
     37 .W !,"Do you wish to enroll the patient from this clinic on "
     38 .S Y=SCASSDT X ^DD("DD") W Y,"?"
     39 .I $$YESNO() D
     40 ..W !,"Clinic Enrollment"
     41 ..I $$ACPTCL^SCAPMC18(DFN,SCCL,,SCASSDT,"SCENER") W " made"
     42 ..E  W "NOT made"
     43QTECL Q
     44DISCL ;
     45 N SCCL F SCCL=0:0 S SCCL=$O(^SCTM(404.57,+$G(SCTP),5,SCCL)) Q:'SCCL  D
     46 .Q:'$$ACTCL(DFN,SCCL)
     47 .W !,$$NAME(DFN)," is enrolled in the associated "_$$CLINIC(SCCL)_" clinic."
     48 .W !,"Do you wish to discharge the patient from this clinic on "
     49 .S Y=SCDISCH X ^DD("DD") W Y,"?"
     50 .Q:'$$YESNO()
     51 .N SDFN,SDCLN S SDFN=DFN,SDCLN=SCCL
     52 .N DFN D ^SDCD
     53QTDCL Q
     54UNTM ;
     55 ;assign patient from pc team (and pc position if possible)
     56 N OK,SCER,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS,OK2,OK3
     57 S OK=0
     58 W !!,"About to Unassign "_$$NAME(DFN)_" from "_$$TEAMNM(SCTM)_" team"
     59 W:'SCTPSTAT !,?5,"AND from "_$$POSITION(SCTP)_" position  ["_$$WRITETP^SCMCDD1(SCTP)_"]"
     60 S SCDISCH=$$DATE("D")
     61 G:SCDISCH<1 QTUNTM
     62 G:'$$CONFIRM() QTUNTM
     63 IF 'SCTPSTAT D  G:OK2'>0 QTUNTM
     64 .W !,"PC assignment unassigned."
     65 .S OK2=$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER)
     66 .IF OK2>0 D
     67 ..W "made."
     68 ..S SCCL=$P(^SCTM(404.57,SCTP,0),U,9)
     69 ..D:SCCL DISCL
     70 S OK3=$$ALLPOS()
     71 IF $$OKINPTTM^SCMCTMU2(DFN,SCTM,SCDISCH) D
     72 .S OK=$$INPTSCTM^SCAPMC7(DFN,SCTM,SCDISCH,.SCER)
     73 ELSE  D
     74 .W !,"Future/Current Patient-Position Assignment exists"
     75QTUNTM W !,"Team Unassignment "_$S(OK:"made",1:"NOT made.")
     76 Q
     77ALLPOS() ;unassign all patient-positions for team
     78 ;not stand-alone - needs dfn,sctm
     79 ;return 1=No positions left assigned|0=At least 1 position assigned
     80 N OK,SCDT1,SCPTTPX,SCERRR,SCTP,SCCNT,SCPTTPI,SCLOC,SCNODE,SCPTTP2
     81 S SCDT1("BEGIN")=SCDISCH+1
     82 S SCDT1("END")=3990101
     83 S SCDT1("INCL")=0  ;anytime from now to future
     84 S OK=$$TPPT^SCAPMC23(DFN,"SCDT1",,,,,,"SCPTTPX",.SCERRR)
     85 S (SCTP,SCCNT)=0
     86 W !,"Checking for other position assignments to team..."
     87 F  S SCTP=$O(SCPTTPX("SCTP",SCTM,SCTP)) Q:'SCTP  S SCCNT=SCCNT+1 D
     88 .S SCPTTPI=$O(SCPTTPX("SCTP",SCTM,SCTP,9999999),-1)
     89 .S SCLOC=$O(SCPTTPX("SCTP",SCTM,SCTP,SCPTTPI,0))
     90 .S SCNODE=SCPTTPX(SCLOC)
     91 .S SCPTTP2(SCTP)=""
     92 .W !,?3,$P(SCNODE,U,2),"   ",$P(SCNODE,U,8)
     93 .IF $P(SCNODE,U,6)!(SCDISCH'>$P(SCNODE,U,5)) D
     94 ..W !,?5,"Unassignment date already exists or unassignment after assignment date"
     95 ..W !,?15,"- Correct via PCMM GUI"
     96 ..S OK=0
     97 W !,?5,$S(SCCNT:SCCNT,1:"No")_" current/future position assignment(s)"
     98 G:'OK!('SCCNT) QTALL
     99 W !!,"About to unassign the above patient-position assignments"
     100 IF '$$CONFIRM S OK=0 G QTALL
     101 S SCTP=0
     102 F  S SCTP=$O(SCPTTP2(SCTP)) Q:'SCTP  D  Q:'OK
     103 .S OK=$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER)
     104 .W:'OK !,?10,"Problem with unassignment, correct via PCMM GUI"
     105QTALL Q OK
     106ASTM ;assign patient to PC team
     107 N DIC,Y,OK,SCTM,SCTMFLDS,SCER,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS
     108 S OK=0
     109 W !!,"About to Assign "_$$NAME(DFN)_" to a primary care team"
     110 I $$SC(DFN) W !!,"********** This patient is 50 percent or greater service-connected ************"
     111 S DIC="^SCTM(404.51,"
     112 S DIC(0)="AEMQZ"
     113 S DIC("S")="IF $$ACTTM^SCMCTMU(Y,DT)&($P($G(^SCTM(404.51,Y,0)),U,5))"
     114 ;select from active teams that can be PC Teams
     115 D ^DIC
     116 G:Y<1 QTASTM
     117 S SCTM=+Y
     118 ;The following logic to present warning message added per SD*5.3*436
     119 I $P($G(^SCTM(404.51,SCTM,0)),U,10) D  G:'SCFLAG QTASTM
     120 .S SCFLAG=0
     121 .W !!,"This team is closed to further patient assignments.  While you are"
     122 .W !,"not currently prevented from assigning this patient, you may want to"
     123 .W !,"check before continuing."
     124 .Q:'$$YESNO1()  ; new function call per SD*5.3*436
     125 .Q:'$$CONFIRM()
     126 .S SCFLAG=1 W !
     127 S SCASSDT=$$DATE("A")
     128 G:SCASSDT<1 QTASTM
     129 S SCTMCT=$$TEAMCNT^SCAPMCU1(SCTM)
     130 S SCTMMAX=$P($$GETEAM^SCAPMCU3(SCTM),"^",8)
     131 I SCTMCT'<SCTMMAX  D  G QTASTM:$$WAITYN(),QTASTM:'$$YESNO2()
     132 .W !,"This assignment will reach or exceeded the maximum set for this team."
     133 .W !,"Currently assigned: "_SCTMCT
     134 .W !,"Maximum set for team: "_SCTMMAX
     135 I SCTMCT<SCTMMAX,'$$CONFIRM() G QTASTM
     136 S SCTM=+Y
     137 ;setup fields
     138 S SCTMFLDS(.08)=1 ;primary care assignment
     139 S SCTMFLDS(.11)=$G(DUZ,.5)
     140 D NOW^%DTC S SCTMFLDS(.12)=%
     141 IF $$ACPTTM^SCAPMC(DFN,SCTM,"SCTMFLDS",SCASSDT,"SCTPTME") D
     142 .S SCSELECT=$$SELPOS()
     143 .D:$L(SCSELECT) ASTP ;prompt for position prompt
     144 .S OK=1
     145QTASTM W !,"Team Assignment "_$S(OK:"made",1:"NOT made.")
     146 S:$D(SDWLPCMM) SDWLPCMM=OK  ; 446
     147 Q
     148ASTP ;assign patient to PC practitioner
     149 N DIC,Y,OK,SCCL,X,SCTPFLDS,SCER,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS
     150 S OK=0
     151 W !!,"About to Assign "_$$NAME(DFN)_" to PC Position Assignment"
     152 I $$SC(DFN) W !!,"********** This patient is 50 percent or greater service-connected ************"
     153 ;lookup to display only position and [practitioner]
     154 IF SCSELECT="PRACT" D
     155 .S DIC("W")="N SCP1 S SCP1=$G(^SCTM(404.52,Y,0)) W ""    ["",$P($G(^VA(200,+$P(SCP1,U,3),0)),U,1),""]"""
     156 .S DIC("A")="POSITION's Current PRACTITIONER: "
     157 .S DIC="^SCTM(404.52,"
     158 .;Must be from team, must be activation,must not have future inactivation
     159 .S DIC("S")="I $$PRACSCR^SCMCQK1(Y)"
     160 .S D="C"
     161 ELSE  D
     162 .S DIC="^SCTM(404.57,"
     163 .S D="B"
     164 .S DIC("A")="POSITION's Name: "
     165 .S DIC("S")="I $$POSSCR^SCMCQK1(Y)"
     166 S DIC(0)="AEMQZ"
     167 D MIX^DIC1
     168 G:Y<1 QTASTP
     169 IF SCSELECT="PRACT" D
     170 .S SCTP=$P(Y,U,2)
     171 ELSE  D
     172 .S SCTP=$P(Y,U,1)
     173 S SCASSDT=$$DATE("A")
     174 G:SCASSDT<1 QTASTP
     175 S SCTMCT=$$PCPOSCNT^SCAPMCU1(SCTP),SCTMMAX=+$P($G(^SCTM(404.57,SCTP,0)),U,8)
     176 I SCTMCT'<SCTMMAX D  G QTASTP:$$WAITYN,QTASTP:'$$YESNO2
     177 .W !,"This assignment will reach or exceeded the maximum set for this position."
     178 .W !,"Currently assigned: "_SCTMCT
     179 .W !,"Maximum set for position: "_SCTMMAX
     180 G:'$$CONFIRM() QTASTP
     181 ;setup fields
     182 S SCTPFLDS(.03)=SCASSDT
     183 S SCTPFLDS(.05)=1 ;pc pract role
     184 S SCTPFLDS(.06)=$G(DUZ,.5)
     185 D NOW^%DTC S SCTPFLDS(.07)=%
     186 IF $$ACPTTP^SCAPMC21(DFN,SCTP,"SCTPFLDS",SCASSDT,"SCTPTME",0) D
     187 .S OK=1
     188 .S SCCL=$O(^SCTM(404.57,+$G(SCTP),5,0))
     189 .D:SCCL ENRCL
     190QTASTP W !,"Position Assignment "_$S(OK:"made",1:"NOT made.")
     191 S:$D(SDWLPCMM) SDWLPCMM=OK ;446
     192 Q
     193NAME(DFN) ;return patient name
     194 Q $P($G(^DPT(DFN,0)),U,1)
     195POSITION(SCTP) ;return position name
     196 Q $P($G(^SCTM(404.57,SCTP,0)),U,1)
     197TEAMNM(SCTM) ;return team name
     198 Q $P($G(^SCTM(404.51,SCTM,0)),U,1)
     199CLINIC(SCCL) ;return clinic name
     200 Q $P($G(^SC(+SCCL,0)),U,1)
     201YESNO() ;
     202 N DIR,X,Y
     203 S DIR(0)="Y",DIR("B")="YES"
     204 D ^DIR
     205 Q Y>0
     206YESNO1() ; added per SD*5.3*436
     207 N DIR,X,Y
     208 S DIR(0)="Y",DIR("A")="Do you wish to assign this patient now (Yes/No)?"
     209 S DIR("B")="NO"
     210 D ^DIR
     211 Q Y>0
     212YESNO2() ;
     213 N DIR,X,Y
     214 S DIR(0)="Y",DIR("B")="NO"
     215 S DIR("A")="Do you wish to continue with the assignment (Yes/No)?"
     216 D ^DIR
     217 Q Y>0
     218CONFIRM() ;confirmation call
     219 N DIR,X,Y
     220 S DIR("A")="Are you sure (Yes/No)"
     221 S DIR(0)="Y"
     222 D ^DIR
     223 Q +Y=1
     224SELPOS() ;return way to select position: 1=PRACT,2=POSIT,3=NONE
     225 N DIR,X,Y
     226 W !,"Choose way to select PC POSITION Assignment: "
     227 S DIR(0)="SO^0:NONE;1:BY PRACTITIONER ASSIGNMENT;2:BY POSITION ASSIGNMENT"
     228 S DIR("B")=1
     229 D ^DIR
     230 Q $S(Y'>0:"",+Y=1:"PRACT",1:"POSIT")
     231DATE(TYPE) ;return date type=A or D
     232 N DIR,X,Y
     233 S DIR("A")=$S(TYPE="A":"Assignment",1:"Unassignment")_" date: "
     234 S DIR(0)="DA^::EXP"
     235 S Y=$S($D(SCDISCH):SCDISCH,$D(SCASSDT):SCASSDT,(TYPE="A"):"TODAY",1:"TODAY-1")
     236 X ^DD("DD")
     237 S DIR("B")=Y
     238 D ^DIR
     239 Q Y
     240ACTCL(DFN,SCCL) ;is patient enrolled in clinic?
     241 N SCXX
     242 S SCXX=$O(^DPT(DFN,"DE","B",SCCL,9999),-1)
     243 Q $S('SCXX:0,($P(^DPT(DFN,"DE",+SCXX,0),U,2)="I"):0,1:1)
     244PRACSCR(SC40452) ;screen for for file 404.52
     245 N SCP,SCNODE,OK
     246 S SCP=$G(^SCTM(404.52,SC40452,0))
     247 S OK=0
     248 G:'SCP QTPP
     249 S SCNODE=$G(^SCTM(404.57,+SCP,0))
     250 S OK=$S($P(SCNODE,U,2)'=SCTM:0,'$P(SCNODE,U,4):0,($O(^SCTM(404.52,"AIDT",+SCP,1,""))'=-$P(SCP,U,2)):0,($O(^SCTM(404.52,"AIDT",+SCP,0,-$P(SCP,U,2)),-1)):0,($$ACTTP^SCMCTPU(+SCP)>0):1,1:0)
     251QTPP Q OK
     252POSSCR(SCTP) ;screen for file 404.57
     253 N SCNODE
     254 S SCNODE=$G(^SCTM(404.57,SCTP,0))
     255 Q $S($P(SCNODE,U,2)'=SCTM:0,'$P(SCNODE,U,4):0,($$ACTTP^SCMCTPU(SCTP)>0):1,1:0)
     256 Q
     257WAITYN() ;
     258 N %,OK,Y
     259 I SCTMCT<SCTMMAX Q 0
     260 N A,SC S A=$$ONWAIT^SCMCWAIT(DFN) I A W:(+A=3) !,$P(A,";",2) I $S($G(SCTP):A>1,1:1) Q 0
     261 N DIR,X,Y
     262 S DIR(0)="Y",DIR("B")="NO"
     263 S DIR("A")="Do you wish to place the patient on the wait list (Yes/No)?"
     264 D ^DIR
     265 I Y=1 S Y=$$WAITS^SCMCWAIT(DFN,SCTM,$G(SCTP),$G(SC)) I Y>0 W !,"Patient Placed on Wait List"
     266 Q Y>0
     267SC(DFN) ;Is patient 50 to 100%
     268 D ELIG^VADPT Q $P($G(VAEL(3)),U,2)>49

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCTSK1.m

    r613 r623  
    1 SCMCTSK1        ;ALB/JDS - PCMM Inactivations; 18 Apr 2003  9:36 AM ; 10/24/07 12:24pm  ; Compiled January 25, 2008 12:11:43  ; Compiled March 26, 2008 22:27:26
    2         ;;5.3;Scheduling;**297,498,527,499**;AUG 13, 1993;Build 21
    3         Q
    4 INACTIVE        ;
    5         ;Flag patients
    6         N I,CNT,SC297,TPZ,TYDT,TEAMN,STDT,Q,SDDT,STDD S CNT=0
    7         D DT^DICRW
    8         N SD1 S SDDT="" F SD1=DT,DT-1 I $D(^XTMP("SCMCTSK2-"_SD1,$J,"START")) S SDDT=SD1 Q
    9         I SDDT'>0 D DT^DICRW S SDDT=DT
    10         S %DT="",X="T-11M" D ^%DT S STDD=+Y
    11         S A="^SCPT(404.43,""ADFN""",L=""""""
    12         S Q=A_")"
    13         F  S Q=$Q(@Q) Q:Q'[A  D
    14         .S ENTRY=+$P(Q,",",6)
    15         .S ZERO=$G(^SCPT(404.43,+ENTRY,0))
    16         .I $P(ZERO,U,15) Q
    17         .S POS=+$P(ZERO,U,2)
    18         .I $P(ZERO,U,4) Q  ;UNASS
    19         .I '$P(ZERO,U,5) Q  ;Not PC
    20         .I $P(ZERO,U,3)>STDD Q  ;<11 months
    21         .I $P(ZERO,U,17) Q  ;React
    22         .;get preceptor
    23         .S PREC=$$DATES^SCAPMCU1(404.53,+POS),PREC=$S(PREC:$P($G(^SCTM(404.53,+$P(PREC,U,4),0)),U,6),1:+POS)
    24         .S DFN=$P(Q,",",3)
    25         .I $G(XPDIDTOT),('(DFN#5)) D UPDATE^XPDID(DFN)
    26         .S TEAM=$P(Q,",",4),TEAMNM=$P($G(^SCTM(404.51,+TEAM,0)),U)
    27         .N STDT S %DT="",X="T-12M" D ^%DT S STDT=+Y
    28         .;N-new or E-est
    29         .N NEW
    30         .I $P(ZERO,U,3)<STDT S NEW=0
    31         .E  S NEW=1
    32         .N TYDT
    33         .I NEW N STDT S %DT="",X="T-11M" D ^%DT S STDT=+Y D
    34         ..S X1=STDT,X2=-7 D C^%DTC S TYDT=X
    35         .I 'NEW N STDT S %DT="",X="T-23M" D ^%DT S STDT=+Y Q:$P(ZERO,U,3)'<STDT  D
    36         ..S X1=STDT,X2=-7 D C^%DTC S TYDT=X
    37         .N PROV,SEEN,PRECP D SEEN(DFN,POS,TYDT,SDDT,.PROV,.PRECP,.SEEN) Q:SEEN
    38         .;flag
    39         .S DIE="^SCPT(404.43,",DR=".15////"_SDDT,DA=ENTRY D ^DIE
    40         .S TPZ=$G(^SCTM(404.57,+POS,2))
    41         .I "TP"[$P(TPZ,U,9) I $G(PROV) S CNT=CNT+1,^TMP("SCF",$J,PROV,CNT,ENTRY)=""
    42         .I $P(TPZ,U,10),$G(PRECP) S CNT=CNT+1,^TMP("SCF",$J,PRECP,CNT,ENTRY)=""
    43         Q
    44 SEEN(DFN,POS,TYDT,SDDT,PROV,PROVP,SEEN) ;
    45         S SEEN=0,PROVP=""
    46         N SCPRO,I,PRO,X,SCPRDTS,SCPR,PREC
    47         S PROV=+$$GETPRTP^SCAPMCU2(POS,SDDT)
    48         S SCPRDTS("BEGIN")=TYDT,SCPRDTS("END")=SDDT,SCPRDTS("INCL")=0
    49         S X=$$PRTP^SCAPMC(POS,"SCPRDTS","SCPR")
    50         S I=0 F  S I=$O(SCPR(I)) Q:'I  S SCPRO(+SCPR(I))="",SCPRO(+SCPR(I),I)=$P(SCPR(I),U,9,10) D
    51         .S PREC=$P(SCPR(I),U,12)
    52         .I PREC,PREC'=POS S PROVP=+$$GETPRTP^SCAPMCU2(PREC,SDDT) S SCPRO(+PROVP)="" S SCPRO(+PROVP,I)=$P(SCPR(I),U,9,10)
    53         F I=TYDT:0 S I=$O(^SCE("ADFN",DFN,I)) Q:'I  D  Q:SEEN
    54         .S J=0 F  S J=$O(^SCE("ADFN",DFN,I,J)) Q:'J  D  Q:SEEN
    55         ..N VISIT S VISIT=+$P($G(^SCE(J,0)),U,5) I $G(^SCE(J,0))<$G(TYDT) Q
    56         ..S PRO=0 F  S PRO=$O(SCPRO(PRO)) Q:'PRO  D  Q:SEEN
    57         ...I $D(^SDD(409.44,"AO",J,$G(PRO))) D CHK I SEEN=1 Q
    58         ...N V F V=0:0 S V=$O(^AUPNVPRV("AD",VISIT,V)) Q:'V  I PRO=(+$G(^AUPNVPRV(V,0))) D CHK I SEEN=1 Q
    59         Q
    60 CHK     ;
    61         N SDX S SDX="" F  S SDX=$O(SCPRO(PRO,SDX)) Q:SDX=""  D  Q:SEEN
    62         .I $P(SCPRO(PRO,SDX),U,2)="" D  Q
    63         ..I I'<$P(SCPRO(PRO,SDX),U) S SEEN=1
    64         .I I'<TYDT&(I'>$P(SCPRO(PRO,SDX),U,2)) S SEEN=1
    65         Q
    66 DIS     ;disch
    67         N ZERO S ZERO=$G(^SCPT(404.43,+ENTRY,0))
    68         I $P(ZERO,U,4) Q
    69         D DIS2^SCMCTSK7
    70         Q
    71 CHKENR(DATA,INFO)       ;check if patient enrolled in teamposition clinic
    72         S DATA(0)=-1
    73         Q
    74 EXTEND(DATA,SCTEAM)     ;to inact. in next 60 days
    75         ;IEN^POSITION^PATIENT^EXTENDED^REASON
    76         K DATA,SCDATA,SDDATA
    77         N CNT,I,J,K,A,POSA S CNT=1 S SCTEAM=$G(SCTEAM),DATA(1)="<DATA>"
    78         D DT^DICRW
    79         N SD1 S SDDT="" F SD1=DT,DT-1 I $D(^XTMP("SCMCTSK2-"_SD1,$J,"START")) S SDDT=SD1 Q
    80         I SDDT'>0 D DT^DICRW S SDDT=DT
    81         S X="T-9M" D ^%DT S STDT=Y
    82         S X="T-21M" D ^%DT S TYDT=+Y  ;MAKE THIS 21
    83         S POSA=""
    84         S POS=+$P(SCTEAM,U,2) I POS D POS,EX1 Q
    85         F  S POSA=$O(^SCTM(404.57,"ATMPOS",+SCTEAM,POSA)) Q:POSA=""  D  Q:CNT>100
    86         .F POS=0:0 S POS=$O(^SCTM(404.57,"ATMPOS",+SCTEAM,POSA,POS)) Q:'POS  D POS Q:CNT>100
    87         I CNT>100 S DATA(1)="TOO MANY" Q
    88 EX1     S A="SDDATA",CNT=1 F  S A=$Q(@A) Q:A=""  D
    89         .S B=@A
    90         .S DATA(CNT)=(+$P(B,U,3))_U_$TR($P($P(A,"(",2),","),$C(34))_U_$TR($P(B,U,2),$C(34))_U_$P($G(^SCPT(404.43,+$P(B,U,3),0)),U,13)_U_$P($G(^SCPT(404.43,+$P(B,U,3),0)),U,14)
    91         .S CNT=CNT+1
    92         Q
    93 POS     I '$$DATES^SCAPMCU1(404.59,POS) Q  ;Position inact
    94         I '$P($G(^SCTM(404.57,POS,0)),U,4) Q  ;Not PC
    95         ;patients for position
    96         K ^TMP("SC TMP LIST",$J)
    97         S X=$$PTTP^SCAPMC(POS,"",.SCLIST,.SCERR)
    98         S J=0 F  S J=$O(@SCLIST@(J)) Q:'J  S SCDATA=^(J) D
    99         .N J I $P(SCDATA,U,4)>STDT Q
    100         .I '$P($G(^SCPT(404.43,+$P(SCDATA,U,3),0)),U,5) Q
    101         .I '$P($G(^SCPT(404.43,+$P(SCDATA,U,3),0)),U,15) Q
    102         .S DFN=+SCDATA
    103         .D SEEN(DFN,POS,TYDT,SDDT,.PROV,.PRECP,.SEEN) Q:SEEN
    104         .S SDDATA($P($G(^SCTM(404.57,POS,0)),U),$P(SCDATA,U,2),+SCDATA)=SCDATA,CNT=CNT+1
    105         K @SCLIST
    106         Q
    107 FILE(RES,DATA)  ;File data on FTEE
    108         N I
    109         F I=1:1 Q:'$D(DATA(I))  D
    110         .S $P(DATA(I),U,7)=$TR($P(DATA(I),U,7),"[]")
    111         .S ZERO=$G(^SCPT(404.43,+DATA(I),0))
    112         .I $P(ZERO,U,13)=$P(DATA(I),U,6) I $P(ZERO,U,14)=$P(DATA(I),U,7) Q
    113         .S FLDA(404.43,(+DATA(I))_",",.13)=$P(DATA(I),U,6)
    114         .S FLDA(404.43,(+DATA(I))_",",.14)=$E($P(DATA(I),U,7),1,50)
    115         .S FLDA(404.43,(+DATA(I))_",",.16)="`"_(+$G(DUZ))
    116         I $O(FLDA(0)) D FILE^DIE("E","FLDA","ERR")
    117         Q
    118 SCREEN  ;Active assign. screen
    119         N A S A=$G(^SCTM(404.52,D0,0))
    120         N J S J=-(DT+1),J=$O(^SCTM(404.52,"AIDT",+A,1,J)) I J="" S X=0 Q
    121         I '$P($G(^SCTM(404.57,+A,0)),U,4) Q  ;Not PC
    122         I '$$DATES^SCAPMCU1(404.59,+A) Q   ;Not an active position
    123         I $O(^SCTM(404.52,"AIDT",+A,0,-(DT+1)))<J S X=0 Q
    124         I '$D(^SCTM(404.52,"AIDT",+A,1,J,D0)) S X=0 Q
    125         S X=1 Q
    126 SUM(PR,POSI)    ;get pos for prov
    127         N I,INS,ZERO,SCA,TEAM,FTEE,Z
    128         S I="",FTEE=0
    129         F  S I=$O(^SCTM(404.52,"C",PR,I),-1) Q:'I  D
    130         .S ZERO=$G(^SCTM(404.52,I,0)) Q:$D(SCA(+ZERO))  Q:(POSI=(+ZERO))  S SCA(+ZERO)=""
    131         .S INS=$P($G(^SCTM(404.51,+$P($G(^SCTM(404.57,+ZERO,0)),U,2),0)),U,7)
    132         .S ACTIVE=$$DATES^SCAPMCU1(404.52,+ZERO,DT+.5) Q:'ACTIVE
    133         .S (Z,ZERO)=$G(^SCTM(404.52,+$P(ACTIVE,U,4),0)) Q:$P(Z,U,3)'=PR
    134         .S ACTIVE=$$DATES^SCAPMCU1(404.59,+Z,DT+.5) Q:'ACTIVE
    135         .S Z=$G(^SCTM(404.57,+Z,0))
    136         .Q:'$P(Z,U,4)  ;Cannot be primary
    137         .S TEAM=$G(^SCTM(404.51,+$P(Z,U,2),0))
    138         .Q:'$P(TEAM,U,5)
    139         .S FTEE=FTEE+$P(ZERO,U,9)
    140         Q FTEE
    141 FTEECHK(DATA,PAIEN)     ;check Ftee>1
    142         N A S A=$G(^SCTM(404.52,+PAIEN,0)),FTEE=$$SUM(+$P(PAIEN,U,3),+A)
    143         S DATA=0
    144         S DATA=FTEE+$P(PAIEN,U,2)
    145         Q
    146 SORT(DIPA,SDD)  ;sort tmpl
    147         N DIC
    148         S DIC=4,DIC(0)="ZME"
    149         S DIC("S")="I $D(^SCTM(404.51,""AINST"",+Y))"
    150         S DIR("A")="Start with Institution",DIR("B")="FIRST",DIR(0)="F" D ^DIR
    151         I X="FIRST" S DIPA("SI")="",DIPA("EI")="zzz",SDD=1 Q
    152         D ^DIC I Y<0 S DIPA("SI")=X S SDD=X Q:SDD[U  D
    153         .S DIR("A")="Go to Institutiton",DIR("B")="LAST" S DIR(0)="F" D ^DIR
    154         .I X="LAST" S DIPA("EI")="zzz"
    155         I Y>0 S DIPA("SI")=$P(Y(0),U),DIC(0)="AZQME",DIC("A")="Go to Institution: "
    156         D ^DIC
    157         I Y>0 S DIPA("EI")=$P(Y(0),U)
    158         I Y<0 S DIPA("EI")=X S SDD=X Q:SDD[U
    159         S SDD=1 Q
    160 FTEERPT ;FTEE REPORT
    161         D FTERPT^SCMCTSK6 Q
    162         Q
    163 POSCHK(DATA,INFO)       ;
    164         N PCLASS
    165         ;TEAM POSITION IEN^PC^STANDARD POSITITION IEN
    166         I '$P(INFO,U,3) S DATA="1^Role Must be Entered" Q
    167         I $P(INFO,U,2) I '$P($G(^SD(403.46,+$P(INFO,U,3),0)),U,3) S DATA="1^This Role cannot provide Primary Care" Q
    168         I $P(INFO,U,2),($P($G(^SD(403.46,+$P(INFO,U,3),0)),U,3)=2) I '$$DATES^SCAPMCU1(404.53,+INFO) S DATA="1^This Role cannot provide Primary Care unless Precepted" Q
    169         S DATA=0
    170         I ('INFO)!('$P(INFO,U,2)) Q
    171         ;Is provider role acceptable?
    172         S J=-(DT+1) S J=$O(^SCTM(404.52,"AIDT",+INFO,1,J)) Q:J=""
    173         I $O(^SCTM(404.52,"AIDT",+INFO,0,-(DT+1)))<J Q
    174         S K=0 S K=$O(^SCTM(404.52,"AIDT",+INFO,1,J,K)) Q:'K
    175         S ZERO=$G(^SCTM(404.52,+K,0))
    176         ;Get person class for provider
    177         S PCLASS=$$GET^XUA4A72(+$P(ZERO,U,3))
    178         ;IEN^Occupation^specialty^sub-specialty^Effective date^expiration date^VA Code^specialty code
    179         I '$D(^SD(403.46,+$P(INFO,U,3),2,"B",+PCLASS)) S DATA="1^Person Class of "_$$GET1^DIQ(200,(+$P(ZERO,U,3))_",",.01)_" is not valid in this Role." D POSCHK^SCMCTSK4
    180         Q
    181 SEED    ;seed one patient/provider
    182         W !,"To retransmit all patients for a given provider press return to select the provider",!!
    183         N DIC,SCADT,SCDDT,SCPAI
    184         S SC177=$$PDAT^SCMCGU("SD*5.3*177")
    185         I +SC177=0 D  Q
    186         . S SC2="  Unable to obtain SD*5.3*177 Installation Date."
    187         . D MSG^SCMCCV6(SC1,SC2)
    188         . Q
    189         S DIC="^DPT(",DIC(0)="MEQA" D ^DIC G PRSEED:Y'>0
    190         ;event filer for 1 patient
    191         S SCDFN=+Y W !,SCDFN
    192 SCDFN   S SC1="^SCPT(404.43,""APCPOS"",SCDFN,1)"
    193         ;quit if no PC assign
    194         Q:'$D(@SC1)
    195         S SCADT=0
    196         F  S SCADT=$O(@SC1@(SCADT)) Q:SCADT=""  D
    197         .S SCTP=0
    198         .F  S SCTP=$O(@SC1@(SCADT,SCTP)) Q:'SCTP  D
    199         ..; quit if team position does not exist
    200         ..Q:'$D(^SCTM(404.57,SCTP,0))
    201         ..S SCPAI=0
    202         ..F  S SCPAI=$O(@SC1@(SCADT,SCTP,SCPAI)) Q:'SCPAI  D
    203         ...S SCDDT=$P($G(^SCPT(404.43,SCPAI,0)),U,4)
    204         ...;quit if not active within date range
    205         ...Q:$$DTCHK^SCAPU1(SC177,DT,0,SCADT,SCDDT)<1
    206         ...N SCVAR S SCVAR=SCPAI_";SCPT(404.43,"
    207         ...;add to HL7 event file
    208         ...Q:$D(^SCPT(404.48,"AACXMIT",SCVAR))
    209         ...Q:$$CHECK^SCMCHLB1(SCVAR)'=1
    210         ...D ADD^SCMCHLE("NOW",SCVAR,SCDFN,SCTP)
    211         Q
    212 PRSEED  ;seed practitioner
    213         N AH,SC177
    214         S SC177=$$PDAT^SCMCGU("SD*5.3*177")
    215         I +SC177=0 D  Q
    216         . S SC2=" No SD*5.3*177 Installation Date."
    217         . D MSG^SCMCCV6(SC1,SC2)
    218         S DIC=200,DIC(0)="MEQA",DIC("A")="Select Provider: " D ^DIC Q:Y'>0
    219         S SCPROV=+Y
    220         F AH=0:0 S AH=$O(^SCTM(404.52,"C",SCPROV,AH)) Q:'AH  S TP=+$G(^SCTM(404.52,+AH,0)) D
    221         . Q:$D(SCTP(TP))
    222         . S SCTP(TP)=1
    223         . F SCDFN=0:0 S SCDFN=$O(^SCPT(404.43,"ADFN",SCDFN)) Q:'SCDFN  I $D(^(SCDFN,TP)) I '$D(SCU(SCDFN)) D SCDFN S SCU(SCDFN)=1
    224         . Q:'$P($G(^SCTM(404.57,TP,0)),U,4)
    225         . S SCVAR=AH_";SCTM(404.52,"
    226         . ;Quit if an event entry already exists
    227         . N QUIT,I S QUIT=0
    228         . F I=0:0 S I=$O(^SCPT(404.48,"AACXMIT",SCVAR,I)) Q:'I  I $P($G(^SCPT(404.48,I,0)),U,8) S QUIT=1 Q
    229         . Q:QUIT
    230         . D ADD^SCMCHLE("NOW",SCVAR,,AH,1)
    231         Q
    232 INCON   ;inconsistent PC assignments
    233         N POS
    234         D INCON^SCMCTSK3
    235         Q
    236 INCONR  ;inconsistent report
    237         N BY
    238         K ^TMP("SCMCTSK",$J)
    239         S DIC="^SCTM(404.57,",(FLDS,BY)="[SCMC INCONSISTENT]",DIOBEG="D INCON^SCMCTSK1"
    240         D EN1^DIP
    241         Q
    242 INACTDT(PA)     ;Scheduled inactivation date.
    243         D INACT^SCMCTSK3 Q
    244 IU(DFN) ;is patient inactivity unassigned
    245         Q $$IU^SCMCTSK3(DFN)
    246         N I,A,B,DATA
     1SCMCTSK1 ;ALB/JDS - PCMM Inactivations; 18 Apr 2003  9:36 AM ; 10/24/07 12:24pm
     2 ;;5.3;Scheduling;**297,498,527**;AUG 13, 1993;Build 6
     3 Q
     4INACTIVE ;run every night to determine if patient can be inactivated from
     5 ;team
     6 ;Inactivation happens for patients without activity for 24 months
     7 N I,CNT,SC297,TPZ,TYDT,TEAMN,STDT,Q S CNT=0
     8 D DT^DICRW S %DT="",X="T-11M" D ^%DT S STDT=Y
     9 S SC297=$$PDAT^SCMCGU("SD*5.3*297"),X1=DT,X2=SC297 D D^%DTC S SC297=X
     10 S X="T-"_$S(SC297>330:"11M",1:"23M") D ^%DT S TYDT=+Y
     11 S A="^SCPT(404.43,""ADFN""",L=""""""
     12 S Q=A_")"
     13 F  S Q=$Q(@Q) Q:Q'[A  D
     14 .S ENTRY=+$P(Q,",",6)
     15 .S ZERO=$G(^SCPT(404.43,+ENTRY,0))
     16 .S POS=+$P(ZERO,U,2)
     17 .S TEAM=$P(Q,",",4)
     18 .;I $P($G(^SCTM(404.51,+TEAM,0)),U,16) Q  ;no automatic for this team
     19 .;I $G(^DPT(DFN,.35)) D DIS Q  ;Patient is deceased
     20 .I $P(ZERO,U,3)>STDT Q  ;Later
     21 .I $P(ZERO,U,17) Q  ;Already reactivated
     22 .;get preceptor position
     23 .S PREC=$$DATES^SCAPMCU1(404.53,+POS),PREC=$S(PREC:$P($G(^SCTM(404.53,+$P(PREC,U,4),0)),U,6),1:+POS)
     24 .;see if provider changed
     25 .I $O(^SCTM(404.52,"AIDT",+PREC,1,-STDT),-1) Q
     26 .I $P(ZERO,U,4) Q  ;Already unassigned
     27 .I '$P(ZERO,U,5) Q  ;Not primary care
     28 .;I $P(ZERO,U,16) Q  ;No Automatic unassign
     29 .;Check if any activity
     30 .S DFN=$P(Q,",",3)
     31 .I $G(XPDIDTOT),('(DFN#5)) D UPDATE^XPDID(DFN)
     32 .S TEAM=$P(Q,",",4),TEAMNM=$P($G(^SCTM(404.51,+TEAM,0)),U)
     33 .D SEEN Q:SEEN
     34 .I '$P(ZERO,U,15) D
     35 ..S DIE="^SCPT(404.43,",DR=".15////"_DT,DA=ENTRY D ^DIE
     36 ..S TPZ=$G(^SCTM(404.57,+POS,2))
     37 ..I "TP"[$P(TPZ,U,10) I $G(PROV) S CNT=CNT+1,^TMP("SCF",$J,PROV,CNT,ENTRY)=""
     38 ..I $P(TPZ,U,9),$G(PRECP) S CNT=CNT+1,^TMP("SCF",$J,PRECP,CNT,ENTRY)=""
     39 Q
     40SEEN ;was patient seen
     41 S SEEN=0
     42 N SCPRO,I,PRECP,PRO
     43 N X,SCPRDTS,SCPR
     44 ;get list of providers for this position
     45 S PROV=+$$GETPRTP^SCAPMCU2(POS,DT) S SCPRO(+PROV)=""
     46 S SCPRDTS("BEGIN")=TYDT
     47 S SCPRDTS("END")=DT
     48 S X=$$PRTP^SCAPMC(POS,"SCPRDTS","SCPR")
     49 F I=0:0 S I=$O(SCPR(I)) Q:'I  S SCPRO(+SCPR(I))=""
     50 S PRECP=0 I $G(PREC),$G(PREC)'=POS S PRECP=+$$GETPRTP^SCAPMCU2(PREC,DT),SCPRO(+PRECP)=""
     51 F I=TYDT:0 S I=$O(^SCE("ADFN",DFN,I)) Q:'I  D  Q:SEEN
     52 .F J=0:0 S J=$O(^SCE("ADFN",DFN,I,J)) Q:'J  D  Q:SEEN
     53 ..N VISIT S VISIT=+$P($G(^SCE(J,0)),U,5) I $G(^SCE(J,0))<$G(TYDT) Q
     54 ..F PRO=0:0 S PRO=$O(SCPRO(PRO)) Q:'PRO  D  Q:SEEN
     55 ...I $D(^SDD(409.44,"AO",J,$G(PRO))) S SEEN=1 Q  ;GET THE PROVIDERJ
     56 ...N V F V=0:0 S V=$O(^AUPNVPRV("AD",VISIT,V)) Q:'V  I PRO=(+$G(^AUPNVPRV(V,0))) S SEEN=1 Q
     57 Q
     58DIS ;discharge
     59 N ZERO S ZERO=$G(^SCPT(404.43,+ENTRY,0))
     60 I $P(ZERO,U,4) Q  ;Already discharged
     61 D DIS2^SCMCTSK7
     62 Q
     63EXTEND(DATA,SCTEAM) ;return list of patients to inactivate in next 60 days
     64 ;IEN^POSITION^PATIENT^EXTENDED^REASON
     65 K DATA,SCDATA,SDDATA
     66 N CNT,I,J,K,A,POSA S CNT=1 S SCTEAM=$G(SCTEAM),DATA(1)="<DATA>"
     67 D DT^DICRW S X="T-9M" D ^%DT S STDT=Y
     68 S X="T-21M" D ^%DT S TYDT=+Y  ;MAKE THIS 21
     69 S POSA=""
     70 S POS=+$P(SCTEAM,U,2) I POS D POS,EX1 Q
     71 F  S POSA=$O(^SCTM(404.57,"ATMPOS",+SCTEAM,POSA)) Q:POSA=""  D  Q:CNT>100
     72 .F POS=0:0 S POS=$O(^SCTM(404.57,"ATMPOS",+SCTEAM,POSA,POS)) Q:'POS  D POS Q:CNT>100
     73 I CNT>100 S DATA(1)="TOO MANY" Q
     74EX1 S A="SDDATA",CNT=1 F  S A=$Q(@A) Q:A=""  D
     75 .S B=@A
     76 .S DATA(CNT)=(+$P(B,U,3))_U_$TR($P($P(A,"(",2),","),$C(34))_U_$TR($P(B,U,2),$C(34))_U_$P($G(^SCPT(404.43,+$P(B,U,3),0)),U,13)_U_$P($G(^SCPT(404.43,+$P(B,U,3),0)),U,14)
     77 .S CNT=CNT+1
     78 Q
     79POS I '$$DATES^SCAPMCU1(404.59,POS) Q   ;Not an active position
     80 I '$P($G(^SCTM(404.57,POS,0)),U,4) Q  ;Not PC
     81 ;get patients for this position
     82 K ^TMP("SC TMP LIST",$J)
     83 S X=$$PTTP^SCAPMC(POS,"",.SCLIST,.SCERR)
     84 S J=0 F  S J=$O(@SCLIST@(J)) Q:'J  S SCDATA=^(J) D
     85 .N J I $P(SCDATA,U,4)>STDT Q
     86 .I '$P($G(^SCPT(404.43,+$P(SCDATA,U,3),0)),U,5) Q
     87 .I '$P($G(^SCPT(404.43,+$P(SCDATA,U,3),0)),U,15) Q
     88 .S DFN=+SCDATA
     89 .D SEEN Q:SEEN
     90 .S SDDATA($P($G(^SCTM(404.57,POS,0)),U),$P(SCDATA,U,2),+SCDATA)=SCDATA,CNT=CNT+1
     91 K @SCLIST
     92 Q
     93FILE(RES,DATA) ;File data on FTEE
     94 N I
     95 F I=1:1 Q:'$D(DATA(I))   D
     96 .S $P(DATA(I),U,7)=$TR($P(DATA(I),U,7),"[]")
     97 .S ZERO=$G(^SCPT(404.43,+DATA(I),0))
     98 .I $P(ZERO,U,13)=$P(DATA(I),U,6) I $P(ZERO,U,14)=$P(DATA(I),U,7) Q
     99 .S FLDA(404.43,(+DATA(I))_",",.13)=$P(DATA(I),U,6)
     100 .S FLDA(404.43,(+DATA(I))_",",.14)=$E($P(DATA(I),U,7),1,50)
     101 .S FLDA(404.43,(+DATA(I))_",",.16)="`"_(+$G(DUZ))
     102 I $O(FLDA(0)) D FILE^DIE("E","FLDA","ERR")
     103 Q
     104SCREEN ;Screen for active assignments
     105 N A S A=$G(^SCTM(404.52,D0,0))
     106 N J S J=-(DT+1),J=$O(^SCTM(404.52,"AIDT",+A,1,J)) I J="" S X=0 Q
     107 I '$P($G(^SCTM(404.57,+A,0)),U,4) Q  ;Not PC
     108 I '$$DATES^SCAPMCU1(404.59,+A) Q   ;Not an active position
     109 I $O(^SCTM(404.52,"AIDT",+A,0,-(DT+1)))<J S X=0 Q
     110 I '$D(^SCTM(404.52,"AIDT",+A,1,J,D0)) S X=0 Q
     111 S X=1 Q
     112SUM(PR,POSI) ; get positions for this provider
     113 N I,INS,ZERO,SCA,TEAM,FTEE,Z
     114 S I="",FTEE=0
     115 F  S I=$O(^SCTM(404.52,"C",PR,I),-1) Q:'I  D
     116 .S ZERO=$G(^SCTM(404.52,I,0)) Q:$D(SCA(+ZERO))  Q:(POSI=(+ZERO))  S SCA(+ZERO)=""
     117 .S INS=$P($G(^SCTM(404.51,+$P($G(^SCTM(404.57,+ZERO,0)),U,2),0)),U,7)
     118 .S ACTIVE=$$DATES^SCAPMCU1(404.52,+ZERO,DT+.5) Q:'ACTIVE
     119 .S (Z,ZERO)=$G(^SCTM(404.52,+$P(ACTIVE,U,4),0)) Q:$P(Z,U,3)'=PR
     120 .S ACTIVE=$$DATES^SCAPMCU1(404.59,+Z,DT+.5) Q:'ACTIVE
     121 .S Z=$G(^SCTM(404.57,+Z,0))
     122 .Q:'$P(Z,U,4)  ;Cannot be primary
     123 .S TEAM=$G(^SCTM(404.51,+$P(Z,U,2),0))
     124 .Q:'$P(TEAM,U,5)
     125 .S FTEE=FTEE+$P(ZERO,U,9)
     126 Q FTEE
     127FTEECHK(DATA,PAIEN) ;check Ftee greater than 1
     128 N A S A=$G(^SCTM(404.52,+PAIEN,0)),FTEE=$$SUM(+$P(PAIEN,U,3),+A)
     129 S DATA=0
     130 S DATA=FTEE+$P(PAIEN,U,2)
     131 Q
     132SORT ;sort template
     133 N DIC,DIPA
     134 S DIC=4,DIC(0)="ZME"
     135 S DIC("S")="I $D(^SCTM(404.51,""AINST"",+Y))"
     136 S DIR("A")="Start with Institution",DIR("B")="FIRST",DIR(0)="F" D ^DIR
     137 I X="FIRST" S DIPA("SI")="",DIPA("EI")="zzz",X=1 Q
     138 D ^DIC I Y<0 S DIPA("SI")=X Q:X[U  D
     139 .S DIR("A")="Go to Institutiton",DIR("B")="LAST" S DIR(0)="F" D ^DIR
     140 .I X="LAST" S DIPA("EI")="zzz"
     141 I Y>0 S DIPA("SI")=$P(Y(0),U),DIC(0)="AZQME",DIC("A")="Go to Institution: "
     142 D ^DIC
     143 I Y>0 S DIPA("EI")=$P(Y(0),U)
     144 I Y<0 S DIPA("EI")=X Q:X[U
     145 S X=1 Q
     146FTEERPT ;FTEE REPORT
     147 D FTERPT^SCMCTSK6 Q
     148 Q
     149POSCHK(DATA,INFO) ;
     150 N PCLASS
     151 ;TEAM POSITION IEN^PC^STANDARD POSITITION IEN
     152 I '$P(INFO,U,3) S DATA="1^Role Must be Entered" Q
     153 I $P(INFO,U,2) I '$P($G(^SD(403.46,+$P(INFO,U,3),0)),U,3) S DATA="1^This Role cannot provide Primary Care" Q
     154 I $P(INFO,U,2),($P($G(^SD(403.46,+$P(INFO,U,3),0)),U,3)=2) I '$$DATES^SCAPMCU1(404.53,+INFO) S DATA="1^This Role cannot provide Primary Care unless Precepted" Q
     155 S DATA=0
     156 I ('INFO)!('$P(INFO,U,2)) Q
     157 ;Check if provider can be in this role.
     158 S J=-(DT+1) S J=$O(^SCTM(404.52,"AIDT",+INFO,1,J)) Q:J=""
     159 I $O(^SCTM(404.52,"AIDT",+INFO,0,-(DT+1)))<J Q
     160 S K=0 S K=$O(^SCTM(404.52,"AIDT",+INFO,1,J,K)) Q:'K
     161 S ZERO=$G(^SCTM(404.52,+K,0))
     162 ;Get person class for provider
     163 S PCLASS=$$GET^XUA4A72(+$P(ZERO,U,3))
     164 ;IEN^Occupation^specialty^sub-specialty^Effective date^expiration date^VA Code^specialty code
     165 I '$D(^SD(403.46,+$P(INFO,U,3),2,"B",+PCLASS)) S DATA="1^Person Class of "_$$GET1^DIQ(200,(+$P(ZERO,U,3))_",",.01)_" is not valid in this Role." D POSCHK^SCMCTSK4
     166 Q
     167SEED ;seed one patient/provider
     168 W !,"To retransmit all patients for a given provider press return to select the provider",!!
     169 N DIC,SCADT,SCDDT,SCPAI
     170 S SC177=$$PDAT^SCMCGU("SD*5.3*177")
     171 I +SC177=0 D  Q
     172 . S SC2="  Unable to obtain SD*5.3*177 Installation Date."
     173 . D MSG^SCMCCV6(SC1,SC2)
     174 . Q
     175 S DIC="^DPT(",DIC(0)="MEQA" D ^DIC G PRSEED:Y'>0
     176 ;event filer for 1 patient
     177 S SCDFN=+Y W !,SCDFN
     178SCDFN S SC1="^SCPT(404.43,""APCPOS"",SCDFN,1)"
     179 ;
     180 ;quit if no PC assignments
     181 Q:'$D(@SC1)
     182 S SCADT=0
     183 F  S SCADT=$O(@SC1@(SCADT)) Q:SCADT=""  D
     184 . S SCTP=0
     185 . F  S SCTP=$O(@SC1@(SCADT,SCTP)) Q:'SCTP  D
     186 . . ;
     187 . . ; quit if team position does not exist
     188 . . Q:'$D(^SCTM(404.57,SCTP,0))
     189 . . S SCPAI=0
     190 . . F  S SCPAI=$O(@SC1@(SCADT,SCTP,SCPAI)) Q:'SCPAI  D
     191 . . . S SCDDT=$P($G(^SCPT(404.43,SCPAI,0)),U,4)
     192 . . . ;
     193 . . . ; quit if not active within date range
     194 . . . Q:$$DTCHK^SCAPU1(SC177,DT,0,SCADT,SCDDT)<1
     195 . . . N SCVAR S SCVAR=SCPAI_";SCPT(404.43,"
     196 . . . ;
     197 . . . ; add to HL7 event file
     198 . . . Q:$D(^SCPT(404.48,"AACXMIT",SCVAR))
     199 . . . Q:$$CHECK^SCMCHLB1(SCVAR)'=1
     200 . . . D ADD^SCMCHLE("NOW",SCVAR,SCDFN,SCTP)
     201 Q
     202PRSEED ;seed practitioner
     203 N AH,SC177
     204 S SC177=$$PDAT^SCMCGU("SD*5.3*177")
     205 I +SC177=0 D  Q
     206 . S SC2="  Unable to obtain SD*5.3*177 Installation Date."
     207 . D MSG^SCMCCV6(SC1,SC2)
     208 . Q
     209 S DIC=200,DIC(0)="MEQA",DIC("A")="Select Provider: " D ^DIC Q:Y'>0
     210 S SCPROV=+Y
     211 F AH=0:0 S AH=$O(^SCTM(404.52,"C",SCPROV,AH)) Q:'AH  S TP=+$G(^SCTM(404.52,+AH,0)) D
     212 . Q:$D(SCTP(TP))
     213 . S SCTP(TP)=1
     214 . F SCDFN=0:0 S SCDFN=$O(^SCPT(404.43,"ADFN",SCDFN)) Q:'SCDFN  I $D(^(SCDFN,TP)) I '$D(SCU(SCDFN)) D SCDFN S SCU(SCDFN)=1
     215 . Q:'$P($G(^SCTM(404.57,TP,0)),U,4)
     216 . S SCVAR=AH_";SCTM(404.52,"
     217 . ;Quit if an event entry already exists
     218 . N QUIT,I S QUIT=0
     219 . F I=0:0 S I=$O(^SCPT(404.48,"AACXMIT",SCVAR,I)) Q:'I  I $P($G(^SCPT(404.48,I,0)),U,8) S QUIT=1 Q
     220 . Q:QUIT
     221 . D ADD^SCMCHLE("NOW",SCVAR,,AH,1)
     222 Q
     223INCON ;get list of incositent provider assignments
     224 N POS
     225 D INCON^SCMCTSK3
     226 Q
     227INCONR ;inconsistent report
     228 N BY
     229 K ^TMP("SCMCTSK",$J)
     230 S DIC="^SCTM(404.57,",(FLDS,BY)="[SCMC INCONSISTENT]",DIOBEG="D INCON^SCMCTSK1"
     231 D EN1^DIP
     232 Q
     233CHKENR(DATA,INFO) ;check if patient enrolled in teamposition clinic
     234 S DATA(0)=-1
     235 N I
     236 N POS,DFN S DFN=+$G(INFO) Q:'DFN  S POS=+$P($G(INFO),U,2) Q:'POS
     237 F I=0:0 S I=$O(^SCTM(404.57,POS,5,I)) Q:'I  D CECHK^SCRPPAT2(I,.CNAME,DFN) I $L(CNAME) S:DATA(0)=-1 DATA(0)="" S DATA(0)=DATA(0)_CNAME_"."
     238 I DATA(0)'=-1 S DATA(0)=$E(DATA(0),1,$L(DATA(0))-2)
     239 Q
     240INACTDT(PA) ;Scheduled inactivation date.
     241 D INACT^SCMCTSK3 Q
     242IU(DFN) ;is patient inactivity unassigned
     243 Q $$IU^SCMCTSK3(DFN)
     244 N I,A,B,DATA

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCTSK2.m

    r613 r623  
    1 SCMCTSK2        ;ALB/JDS - PCMM Inactivation Nightly Job; 18 Apr 2003  9:36 AM ; 10/24/07 12:23pm  ; Compiled November 21, 2007 13:32:47  ; Compiled March 17, 2008 15:27:15
    2         ;;5.3;Scheduling;**297,498,527,499**;AUG 13, 1993;Build 21
    3         Q
    4 NIGHT   ;
    5         N ENDDT,NOINAC,SIXM,FLGDT,L,PATDT,SEEN,SDDT
    6         D DT^DICRW S SDDT=$P($G(^XTMP("SCMCTSK2-"_DT,0)),U,2)
    7         I SDDT="" S SDDT=DT
    8         S ALPHA=$G(^SCTM(404.44,1,1)),ALPHA=$P(ALPHA,U,8) I ALPHA<SDDT S ALPHA=0
    9         ;if 'ALPHA NOINAC=1 except 15th and the Last Day of a Month (LDoM)
    10         ;inact only on 15th and on LDoM
    11         S NOINAC=0
    12         I 'ALPHA  S X1=SDDT,X2=1 D C^%DTC I ($E(SDDT,6,7)'=15)&($E(SDDT,1,5)=$E(X,1,5)) S NOINAC=1
    13         I 'ALPHA D INACTIVE^SCMCTSK1
    14         S SIXM=$P($G(^SCTM(404.44,1,1)),U,9)
    15         I SIXM D PRFLAG
    16         I ALPHA D INACTIVE^SCMCTSK1
    17         ;determine ENDDT-Inactn Date-30 days if flagged today
    18         F DATE=0:0 S DATE=$O(^SCPT(404.43,"AFLG",DATE)) Q:'DATE  D
    19         .F ENTRY=0:0 S ENTRY=$O(^SCPT(404.43,"AFLG",DATE,ENTRY)) Q:'ENTRY  D
    20         ..S ZERO=$G(^SCPT(404.43,ENTRY,0)) Q:'ZERO
    21         ..S DFN=+$G(^SCPT(404.42,+ZERO,0)) Q:'DFN
    22         ..S POS=$P(ZERO,U,2)
    23         ..I $P(ZERO,U,4) D UNFLG Q  ;unass.
    24         ..S X1=DATE,X2=$S(ALPHA:+2,1:+30) D C^%DTC S ENDDT=X
    25         ..N SDASS S SDASS=$P(ZERO,U,3)
    26         ..;N-new or E-stbl.
    27         ..;assig >12 months since flagging, not NEW, E-stbl)
    28         ..N NEW
    29         ..S NEW=0 S X1=DATE,X2=SDASS D ^%DTC I X<365 S NEW=1
    30         ..I NEW S %DT="",X="T-12M" D ^%DT S STDT=+Y D
    31         ...S X1=STDT,X2=-7 D C^%DTC S TYDT=X
    32         ..I 'NEW S %DT="",X="T-24M" D ^%DT S STDT=+Y D
    33         ...S X1=STDT,X2=-7 D C^%DTC S TYDT=X
    34         ..;
    35         ..I $P(ZERO,U,17) D UNFLG Q  ;react.
    36         ..;get prec
    37         ..;S %DT="",X="T-12M" D ^%DT S STDT=+Y
    38         ..;S PREC=$$DATES^SCAPMCU1(404.53,+POS),PREC=$S(PREC:$P($G(^SCTM(404.53,+$P(PREC,U,4),0)),U,6),1:+POS)
    39         ..I '$P(ZERO,U,5) D UNFLG Q  ;Not PC
    40         ..D SEEN^SCMCTSK1(DFN,POS,TYDT,SDDT,.PROV,.PRECP,.SEEN)
    41         ..;S PC=$$GET^XUA4A72(+PROV)
    42         ..I SEEN D UNFLG Q
    43         ..I $P(ZERO,U,13) S X1=DATE,X2=$S(ALPHA:4,1:90) D C^%DTC S FLGDT=X I FLGDT>SDDT Q  ;do not inactivate yet; extended
    44         ..I ('NOINAC)&(SDDT'<ENDDT) D DIS^SCMCTSK1
    45         ;flag prov 6m after install sd/297
    46         I NOINAC D:ALPHA BULL I '$D(^SCPT(404.43,"AFLG",SDDT)) K ^TMP($J,"SCMCTSK2") Q
    47         ;flag prov 6m after install sd/297
    48         I SIXM,SIXM'>SDDT D
    49         .D PRINAC
    50         .N FLDA
    51         .S FLDA(404.44,"1,",19)=""
    52         .D FILE^DIE("I","FLDA","ERR")
    53         D BULL K ^TMP($J,"SCMCTSK2")
    54         Q
    55 UNFLG   ;Unflagging
    56         N DR,DIE,DA
    57         S DR=".15///@;.13///@;.12///@",DIE="^SCPT(404.43,",DA=ENTRY D ^DIE
    58         Q
    59 PRFLAG  ;flag incorrect provider pos
    60         N POS
    61         ;prov inact. has run once
    62         I $P($G(^SCTM(404.44,1,1)),U,11)'="" Q
    63         D PRFLAG^SCMCTSK3
    64         Q
    65 PRINAC  ;inact. flagged providers
    66         N I,II
    67         ;Prov inact. run already
    68         I $G(SDDT)="" S SDDT=DT
    69         S II=$P($G(^SCTM(404.44,1,1)),U,11) I II'="",II'=SDDT Q
    70         F I=0:0 S I=$O(^SCTM(404.52,I)) Q:'I  S ZERO=$G(^(I,0)) I $P(ZERO,U,10) D
    71         .;I $P(ZERO,U,10)>$G(ENDT) Q   ;not time yet
    72         .I $O(^SCTM(404.52,"AIDT",+ZERO,0,-9999999))<(-$P(ZERO,U,2)) Q   ;inactivated
    73         .;Check valid criteria
    74         .S POS=+ZERO
    75         .S PROV=+$$GETPRTP^SCAPMCU2(POS,SDDT)
    76         .S PC=$$GET^XUA4A72(+PROV)
    77         .S DR=".091///@",DIE="^SCTM(404.52,",DA=I D ^DIE  ;remove flag
    78         .S ZERO1=$G(^SCTM(404.57,POS,0))
    79         .I '$D(^SD(403.46,+$P(ZERO1,U,3),2,+PC)) D
    80         ..;inactivation
    81         ..S DIC="^SCTM(404.52,",X=+ZERO,DIC("DR")=".02////"_SDDT_";.03////"_$P(ZERO,U,3)_";.04////0;.05///EMPLOYEE LEAVES POSITION;.11////1"
    82         ..S DIC(0)="LM" D ^DIC
    83         ;only run inact. once
    84         S $P(^SCTM(404.44,1,1),U,11)=SDDT
    85         Q
    86 FUTAPP(DFN)     ;print future appts
    87         N TAB,SCDT0 S TAB=$X
    88         I $G(SDDT)="" S SDDT=DT
    89         S SCDT=SDDT+.24
    90         F  S SCDT=$O(^DPT(DFN,"S",SCDT)) Q:'SCDT  D
    91         . S SCDT0=$G(^DPT(DFN,"S",SCDT,0)) Q:$L($P(SCDT0,U,2))
    92         . S CLIEN=$P(SCDT0,"^") Q:'CLIEN
    93         . S Y=SCDT X ^DD("DD") W $E(Y_" ",1,17)_" "_$E($P($G(^SC(+CLIEN,0)),U),1,10)
    94         Q
    95 GETASC(DATA,ENTRY)      ;get assoc. clinics
    96         N I,CNT S CNT=0
    97         F I=0:0 S I=$O(^SCTM(404.57,+$G(ENTRY),5,I)) Q:'I  S CNT=CNT+1,DATA(CNT)=I_U_$P($G(^SC(I,0)),U)
    98         Q
    99 SETASC(RESULT,DATA)     ;set assoc. clinics
    100         D SETASC^SCMCTSK7(.RESULT,DATA) Q
    101 MSG(SCTP,DFN)   ;send inact. message
    102         ;given valid positions get current practitioners
    103         S SCLIST="SCL"
    104         I $G(SDDT)="" S SDDT=DT
    105         I "N"'[$P($G(^SCTM(404.57,SCTP,2)),U,9) D
    106         .S SCOK=$$PRTP^SCAPMC(SCTP,"",.SCLIST,.SCERR)
    107         .;if preceptor notice turned on for message type
    108         I +$P($G(^SCTM(404.57,SCTP,2)),U,9) D
    109         .S SCX=+$$OKPREC2^SCMCLK(SCTP,SDDT)
    110         .;if preceptor duz returned, add to array
    111         .I SCX S @SCLIST@("SCPR",SCX)=""
    112         N XMY F I=0:0 S I=$O(@SCLIST@("SCPR",I)) Q:'I  S XMY(I)=""
    113         S SCTEXT(1,0)="PATIENT "_$P($G(^DPT(DFN,0)),U)_" has been inactivated from PC team position "_$P($G(^SCTM(404.57,SCTP,0)),U)
    114         S XMSUB="Provider's Inactivated Primary Care Patients" D ^XMD
    115         Q
    116 BULL    ;EOM Bulletin
    117         N DISUPNO,BY,DHIT,HEAD
    118         S DISUPNO=1,L=0
    119         S XMSUB="Patients Scheduled for Inactivation from PC Panel"
    120         S XMY("G.PCMM PATIENT/PROVIDER INACTIVE")=""
    121         K ^TMP("SCMC",$J),^TMP("SCMCTXT",$J),^TMP("SCML",$J)
    122         S XMTEXT="^TMP(""SCMCTXT"",$J," ;S @XMTEXT@(0)=""
    123         S DIC="^SCPT(404.43,",BY="[SCMC FLAGGED BULLETIN]",FLDS="[SC BULLETIN]",CNT=0
    124         S:0 FLDS="" S IOP="",DHD="@@",(FR,TO)="" D EN1^DIP
    125         S ^TMP("SCMCTXT",$J,1,0)="There are "_$O(^TMP("SCMC",$J,""),-1)_" Patients scheduled for inactivation in next 30 days"
    126         D LINES(1)
    127         D ^XMD
    128         D PRMAIL^SCMCTSK5(1)
    129         F SCI=0:0 S SCI=$O(^TMP("SCF",$J,SCI)) Q:'SCI  D
    130         .K XMY S XMY(SCI)="" K ^TMP("SCMC",$J),^TMP("SCMCTXT",$J)
    131         .M ^TMP("SCMC",$J)=^TMP("SCF",$J,SCI)
    132         .S XMSUB="Patients Scheduled for Inactivation from PC Panel"
    133         .S XMTEXT="^TMP(""SCMCTXT"",$J,"
    134         S DISUPNO=1
    135         K ^TMP("SCMC",$J),^TMP("SCMCTXT")
    136         I $G(NOINAC) K ^TMP($J,"SCMCTSK2") Q  ; SD/499
    137         S XMSUB="Patients With Extended PCMM Inactivation Dates"
    138         S XMY("G.PCMM PATIENT/PROVIDER INACTIVE")=""
    139         K ^TMP("SCMC",$J)
    140         S XMTEXT="^TMP(""SCMCTXT"",$J," ;S @XMTEXT@(0)=""
    141         S DIC="^SCPT(404.43,",BY="[SCMC EXTENDED BULLETIN]",DHIT="S CNT=$G(CNT)+1,^TMP(""SCMC"",$J,CNT,D0)=""""",CNT=0
    142         S FR=",,,",TO=FR,FLDS="",IOP="",DHD="@@" D EN1^DIP
    143         S ^TMP("SCMCTXT",$J,1,0)="There are "_$O(^TMP("SCMC",$J,""),-1)_" Patients Extended from inactivation"
    144         D LINES(3)
    145         D ^XMD
    146         D PRMAIL^SCMCTSK5(3)
    147         S DISUPNO=1
    148         K ^TMP("SCMC",$J),^TMP("SCMCTXT")
    149         S XMSUB="Patients Automated Inactivations from PC Panels"
    150         S XMY("G.PCMM PATIENT/PROVIDER INACTIVE")=""
    151         K ^TMP("SCMC",$J)
    152         S XMTEXT="^TMP(""SCMCTXT"",$J," ;S @XMTEXT@(0)=""
    153         S DIC="^SCPT(404.43,",BY="[SCMC INACTIVATED]",DHIT="S CNT=$G(CNT)+1,^TMP(""SCMC"",$J,CNT,D0)=""""",CNT=0
    154         S FLDS="",IOP="",DHD="@@",FR=",T-30,,",TO=",,,,," D EN1^DIP
    155         S ^TMP("SCMCTXT",$J,1,0)="There are "_$O(^TMP("SCMC",$J,""),-1)_" Patients Inactivated in last 30 days"
    156         D LINES(2)
    157         D ^XMD
    158         S DISUPNO=1
    159         D PRMAIL^SCMCTSK5(2)
    160         K ^TMP("SCMC",$J),^TMP("SCMCTXT")
    161         I $P($G(^SCTM(404.44,1,1)),U,11)="" D
    162         . S XMSUB="PC Providers Scheduled for Inactivation"
    163         . S XMY("G.PCMM PATIENT/PROVIDER INACTIVE")=""
    164         . K ^TMP("SCMC",$J)
    165         . S XMTEXT="^TMP(""SCMCTXT"",$J,"
    166         . S DIC="^SCTM(404.52,",BY="[SC PROVIDER FLAGGED BULLE]",DHIT="S CNT=$G(CNT)+1,^TMP(""SCMC"",$J,CNT,D0)=""""",CNT=0
    167         . S FLDS="",IOP="",DHD="@@",FR="",TO="" D EN1^DIP
    168         . D LINES(4)
    169         . D ^XMD
    170         . D PRMAIL^SCMCTSK5(4)
    171         . D BULL^SCMCTSK6
    172         Q
    173 LINES(TYPE)     ;Lines of Bulletin
    174         D LINES^SCMCTSK5(TYPE) Q
    175 ROLE(DATA,INFO) ;SCMC ROLE
    176         N ROLE,TP,I
    177         S ROLE=+$G(INFO),TP=+$P($G(INFO),U,2)
    178         S DATA(0)="0^0^0"
    179         I 'ROLE Q
    180         I 'TP Q
    181         S DATA(0)=+$P($G(^SD(403.46,ROLE,0)),U,3) ;I DATA(0)=3!(DATA(0)=0) S DATA(0)=DATA(0)_"^0^0" Q
    182         I $$DATES^SCAPMCU1(404.53,+TP) S DATA(0)=DATA(0)_"^1^0" Q
    183         N PREC S PREC=0
    184         F I=0:0 S I=$O(^SCTM(404.53,"AD",TP,I)) Q:'I  D   Q:PREC
    185         .I $D(^SCTM(404.53,"AD",TP,I,1)) I '$D(^(0)) S PREC=1
    186         I PREC S DATA(0)=DATA(0)_"^0^1" Q
    187         S DATA(0)=DATA(0)_"^0^0"
    188         Q
    189 INRPT    ; REPORT
    190         N DIOEND,SCDHD
    191         D PROMPT^SCMCTSK3("** Date Range Selection **","DATE PATIENTS INACTIVATED FROM PC PANELS")
    192         Q:'$D(^TMP("SC",$J,"XR"))
    193         D UNASSIGN^SCMCTSK3
    194         S Q=""""
    195         S DIC="^SCPT(404.43," ;=0,BY="[SCMC INACTIVATION SORT]"
    196         D BY
    197         S (SCDHD,DHD)="AUTOMATED PATIENT INACTIVATION FROM PRIMARY CARE PANELS REPORT"
    198         S DIOBEG="D DIOBEG^SCMCTSK4"
    199         S DIOEND="D DIOEND1^SCMCTSK4"
    200         S FLDS="[SCMC INACTIVATED]" ;,FR="?,,"_$TR(DIPA("SI"),","," "),TO="T,,"_$TR(DIPA("EI")_"z",","," ")
    201         D EN1^DIP
    202         Q
    203 IN30    ;inact. last month
    204         N DIPA,SDD D SORT^SCMCTSK1(.DIPA,.SDD) Q:'SDD  ;SD/499
    205         S Q=""""
    206         S DIC="^SCPT(404.43,",L=0,BY="[SCMC INACTIVATION SORT]"
    207         S DHD="Patients Inactivated from Primary Care Panels in the Past Month"
    208         S FLDS="[SCMC INACTIVATED]",FR="T-31,,"_$TR(DIPA("SI"),","," "),TO="T,,"_$TR(DIPA("EI")_"z",","," ")
    209         D EN1^DIP
    210         Q
    211 EXRPT    ;EXTEND REPORT
    212         K CLIN,TEAM,INST
    213         D PROMPT^SCMCTSK3("PCMM Patients with Extended Inactivations","Scheduled Inactivation Date")
    214         Q:'$D(^TMP("SC",$J,"XR"))
    215         S Q="""",SORT=1
    216         D EXTEND^SCMCTSK3
    217         S DIC="^SCPT(404.43," ;,L=0,BY="[SCMC EXTENDED]"
    218         S (SCDHD,DHD)="PCMM Patients with extended Inactivations"
    219         S DIOBEG="D DIOBEG^SCMCTSK4",DIOEND="D EXTKEY^SCMCTSK9"
    220         D BY
    221         S FLDS="[SCMC EXTENDED]"
    222         D EN1^DIP
    223         Q
    224 BY      N DISPAR
    225         S BY(0)="^TMP(""SCSORT"",$J)",L(0)=$O(^TMP("SC",$J,"SORT",99),-1)+1,DISPAR(0,1)="+",L=0 I $G(SCDHD)["FTEE" S DISPAR(0,1)="+#" ;BY="@'.01"
    226         F I=1:1:$L(SORTN,U) S A=$P(SORTN,U,I) Q:'$L(A)  S $P(DISPAR(0,I),U,2)=";"_Q_A_": "_Q D
    227         .I A["PATIENT" I (I>1)!($G(SCDHD)["Patients Scheduled for Inactivation from PC Panel") S $P(DISPAR(0,I),U)="@"
    228         .I $G(SCDHD)["FTEE" D
    229         ..I A["PROV" S $P(DISPAR(0,I),U)="@"
    230         ..I I>1 I (A["CLI")!(A["POS") S $P(DISPAR(0,I),U)="@"_$P($G(DISPAR(0,I)),U)
    231         S ZTSAVE("^TMP(""SC"",$J,")="",ZTSAVE("^TMP(""SCSORT"",$J,")=""
    232         Q
    233 FLRPT    ;FLAGGED REPORT
    234         D PROMPT^SCMCTSK3("Patients Scheduled for Inactivation from PC Panels","Date Scheduled for Inactivation")
    235         Q:'$D(^TMP("SC",$J,"XR"))
    236         D FLAGG^SCMCTSK3
    237         S Q=""""
    238         S DIC="^SCPT(404.43,",L=0
    239         S (SCDHD,DHD)="Patients Scheduled for Inactivation from PC Panels"
    240         D BY
    241         S DIOBEG="D DIOBEG^SCMCTSK4"
    242         S FLDS="[SCMC PENDING UNASSIGN]"
    243         I $G(DISPAR(0,1))["PATIENT" S FLDS="[SCMC PENDING UNASSIGN PAT]"
    244         S DIOEND="D DIOEND^SCMCTSK4"
    245         D EN1^DIP
     1SCMCTSK2 ;ALB/JDS - PCMM Inactivation Nightly Job; 18 Apr 2003  9:36 AM ; 10/24/07 12:23pm
     2 ;;5.3;Scheduling;**297,498,527**;AUG 13, 1993;Build 6
     3 Q
     4NIGHT ;nightly task for inact.
     5 N ENDDT,NOINAC,SIXM,FLGDT,L,PATDT,SEEN
     6 K ^TMP("SCTSK",$J)
     7 D DT^DICRW
     8 S ALPHA=$G(^SCTM(404.44,1,1)),ALPHA=$P(ALPHA,U,8) I ALPHA<DT S ALPHA=0
     9 ;check if this is last day of month
     10 S X1=DT,X2=1 D C^%DTC I $E(DT,1,5)'=$E(X,1,5) I 'ALPHA D INACTIVE^SCMCTSK1
     11 S SIXM=$P($G(^SCTM(404.44,1,1)),U,9)
     12 I SIXM D PRFLAG
     13 I ALPHA D INACTIVE^SCMCTSK1
     14 S NOINAC=0 I 'ALPHA  S X1=DT,X2=1 D C^%DTC I ($E(DT,6,7)'=15)&($E(DT,1,5)=$E(X,1,5)) S NOINAC=1
     15 ;check for 60 days after flagged for inact.
     16 S X1=DT,X2=$S(ALPHA:-2,1:-30) D C^%DTC S ENDDT=X
     17 F DATE=0:0 S DATE=$O(^SCPT(404.43,"AFLG",DATE)) Q:(('DATE)!(('NOINAC)&(DATE>ENDDT)))  D
     18 .F ENTRY=0:0 S ENTRY=$O(^SCPT(404.43,"AFLG",DATE,ENTRY)) Q:'ENTRY  D
     19 ..S ZERO=$G(^SCPT(404.43,ENTRY,0)) Q:'ZERO
     20 ..S DFN=+$G(^SCPT(404.42,+ZERO,0)) Q:'DFN
     21 ..S POS=$P(ZERO,U,2)
     22 ..I $P(ZERO,U,4) D UNFLG Q  ;already unassigned
     23 ..I $P(ZERO,U,13) S X1=DATE,X2=$S(ALPHA:4,1:90) D C^%DTC S FLGDT=X I FLGDT>DT Q    ;ext
     24 ..;check if criteria still met
     25 ..I $P(ZERO,U,17) D UNFLG Q  ;Already reactivated
     26 ..;get preceptor position
     27 ..S %DT="",X="T-12M" D ^%DT S STDT=+Y
     28 ..S PREC=$$DATES^SCAPMCU1(404.53,+POS),PREC=$S(PREC:$P($G(^SCTM(404.53,+$P(PREC,U,4),0)),U,6),1:+POS)
     29 ..;see if provider changed
     30 ..I $O(^SCTM(404.52,"AIDT",+PREC,1,-STDT),-1) D UNFLG Q
     31 ..I '$P(ZERO,U,5) D UNFLG Q  ;Not primary care
     32 ..S PROV=+$$GETPRTP^SCAPMCU2(POS,DT)
     33 ..S PC=$$GET^XUA4A72(+PROV)
     34 ..S SC297=$$PDAT^SCMCGU("SD*5.3*297")
     35 ..N NEW S NEW=$S($P(ZERO,U,3)<SC297:0,1:1)   ;D D^%DTC S NEW=$S(X>330:0,1:1)
     36 ..S X1=DT,X2=SC297 D D^%DTC S SC297=X
     37 ..S X="T-"_$S(SC297>365:"11M",NEW:"11M",1:"23M") D ^%DT S TYDT=+Y D SEEN^SCMCTSK1 I $G(SEEN) D UNFLG Q
     38 ..S X="T-"_$S(SC297>365:"12M",NEW:"12M",1:"24M") D ^%DT S TYDT=+Y D SEEN^SCMCTSK1 I $G(SEEN) D:(DATE>ENDDT) UNFLG Q
     39 ..I ('NOINAC)&(DATE'>ENDDT) D DIS^SCMCTSK1
     40 ..;D MSG(POS,DFN)
     41 ;if 6 months after installation check to flag providers
     42 I NOINAC D:ALPHA BULL Q
     43 S PATDT=$$PDAT^SCMCGU("SD*5.3*297") Q:'PATDT
     44 I SIXM,SIXM'>DT D
     45 .D PRINAC
     46 .N FLDA
     47 .S FLDA(404.44,"1,",19)=""
     48 .D FILE^DIE("I","FLDA","ERR")
     49 D BULL
     50 Q
     51UNFLG ;Remove the flag
     52 N DR,DIE,DA
     53 S DR=".15///@;.13///@;.12///@",DIE="^SCPT(404.43,",DA=ENTRY D ^DIE
     54 Q
     55PRFLAG ;flag incorrect provider positions
     56 N POS
     57 ;provider inactivation has run once
     58 I $P($G(^SCTM(404.44,1,1)),U,11)'="" Q
     59 D PRFLAG^SCMCTSK3
     60 Q
     61PRINAC ;inactivate flagged providers
     62 N I,II
     63 ;Provider inactivation run already
     64 S II=$P($G(^SCTM(404.44,1,1)),U,11) I II'="",II'=DT Q
     65 F I=0:0 S I=$O(^SCTM(404.52,I)) Q:'I  S ZERO=$G(^(I,0)) I $P(ZERO,U,10) D
     66 .;I $P(ZERO,U,10)>$G(ENDT) Q   ;not time yet
     67 .I $O(^SCTM(404.52,"AIDT",+ZERO,0,-9999999))<(-$P(ZERO,U,2)) Q   ;already inactivated
     68 .;Check if criteria still valid
     69 .S POS=+ZERO
     70 .S PROV=+$$GETPRTP^SCAPMCU2(POS,DT)
     71 .S PC=$$GET^XUA4A72(+PROV)
     72 .S DR=".091///@",DIE="^SCTM(404.52,",DA=I D ^DIE  ;remove flag
     73 .S ZERO1=$G(^SCTM(404.57,POS,0))
     74 .I '$D(^SD(403.46,+$P(ZERO1,U,3),2,+PC)) D
     75 ..;enter the inactivation
     76 ..S DIC="^SCTM(404.52,",X=+ZERO,DIC("DR")=".02////"_DT_";.03////"_$P(ZERO,U,3)_";.04////0;.05///EMPLOYEE LEAVES POSITION;.11////1"
     77 ..S DIC(0)="LM" D ^DIC
     78 ;only run the inactivation once.
     79 S $P(^SCTM(404.44,1,1),U,11)=DT
     80 Q
     81FUTAPP(DFN) ;print future appointments
     82 N TAB,SCDT0 S TAB=$X
     83 S SCDT=DT+.24
     84 F  S SCDT=$O(^DPT(DFN,"S",SCDT)) Q:'SCDT  D
     85 . S SCDT0=$G(^DPT(DFN,"S",SCDT,0)) Q:$L($P(SCDT0,U,2))
     86 . S CLIEN=$P(SCDT0,"^") Q:'CLIEN
     87 . S Y=SCDT X ^DD("DD") W $E(Y_" ",1,17)_" "_$E($P($G(^SC(+CLIEN,0)),U),1,10)
     88 Q
     89GETASC(DATA,ENTRY) ;get associated clinics
     90 N I,CNT S CNT=0
     91 F I=0:0 S I=$O(^SCTM(404.57,+$G(ENTRY),5,I)) Q:'I  S CNT=CNT+1,DATA(CNT)=I_U_$P($G(^SC(I,0)),U)
     92 Q
     93SETASC(RESULT,DATA) ;set associated clinics
     94 D SETASC^SCMCTSK7(.RESULT,DATA) Q
     95MSG(SCTP,DFN) ;send inactivation message
     96         ;given list of valid positions get current practitioners
     97 S SCLIST="SCL"
     98 I "N"'[$P($G(^SCTM(404.57,SCTP,2)),U,9) D
     99 .S SCOK=$$PRTP^SCAPMC(SCTP,"",.SCLIST,.SCERR)
     100 .;if preceptor notice turned on for message type
     101 I +$P($G(^SCTM(404.57,SCTP,2)),U,9) D
     102 .S SCX=+$$OKPREC2^SCMCLK(SCTP,DT)
     103 .;if preceptor duz returned, add to array
     104 .I SCX S @SCLIST@("SCPR",SCX)=""
     105 N XMY F I=0:0 S I=$O(@SCLIST@("SCPR",I)) Q:'I  S XMY(I)=""
     106 S SCTEXT(1,0)="PATIENT "_$P($G(^DPT(DFN,0)),U)_" has been inactivated from primary care team position "_$P($G(^SCTM(404.57,SCTP,0)),U)
     107 S XMSUB="Provider's Inactivated Primary Care Patients" D ^XMD
     108 Q
     109BULL ;end of Month Bulletin
     110 N DISUPNO,BY,DHIT,HEAD
     111 S DISUPNO=1,L=0
     112 S XMSUB="Patients Scheduled for Inactivation from Primary Care Panel"
     113 S XMY("G.PCMM PATIENT/PROVIDER INACTIVE")=""
     114 K ^TMP("SCMC",$J),^TMP("SCMCTXT",$J),^TMP("SCML",$J)
     115 S XMTEXT="^TMP(""SCMCTXT"",$J," ;S @XMTEXT@(0)=""
     116 S DIC="^SCPT(404.43,",BY="[SCMC FLAGGED BULLETIN]",FLDS="[SC BULLETIN]",CNT=0
     117 S:0 FLDS="" S IOP="",DHD="@@",(FR,TO)="" D EN1^DIP
     118 S ^TMP("SCMCTXT",$J,1,0)="There are "_$O(^TMP("SCMC",$J,""),-1)_" Patients scheduled for inactivation in next 30 days"
     119 D LINES(1)
     120 D ^XMD
     121 D PRMAIL^SCMCTSK5(1)
     122 F SCI=0:0 S SCI=$O(^TMP("SCF",$J,SCI)) Q:'SCI  D
     123 .K XMY S XMY(SCI)="" K ^TMP("SCMC",$J),^TMP("SCMCTXT",$J)
     124 .M ^TMP("SCMC",$J)=^TMP("SCF",$J,SCI)
     125 .S XMSUB="Patients Scheduled for Inactivation from Primary Care Panel"
     126 .S XMTEXT="^TMP(""SCMCTXT"",$J,"
     127 .;D LINES(1) D ^XMD
     128 S DISUPNO=1
     129 K ^TMP("SCMC",$J),^TMP("SCMCTXT")
     130 S XMSUB="Patients With Extended PCMM Inactivation Dates"
     131 S XMY("G.PCMM PATIENT/PROVIDER INACTIVE")=""
     132 K ^TMP("SCMC",$J)
     133 S XMTEXT="^TMP(""SCMCTXT"",$J," ;S @XMTEXT@(0)=""
     134 S DIC="^SCPT(404.43,",BY="[SCMC EXTENDED BULLETIN]",DHIT="S CNT=$G(CNT)+1,^TMP(""SCMC"",$J,CNT,D0)=""""",CNT=0
     135 S FR=",,,",TO=FR,FLDS="",IOP="",DHD="@@" D EN1^DIP
     136 S ^TMP("SCMCTXT",$J,1,0)="There are "_$O(^TMP("SCMC",$J,""),-1)_" Patients Extended from inactivation"
     137 D LINES(3)
     138 D ^XMD
     139 D PRMAIL^SCMCTSK5(3)
     140 S DISUPNO=1
     141 K ^TMP("SCMC",$J),^TMP("SCMCTXT")
     142 S XMSUB="Patients Automated Inactivations from Primary Care Panels"
     143 S XMY("G.PCMM PATIENT/PROVIDER INACTIVE")=""
     144 K ^TMP("SCMC",$J)
     145 S XMTEXT="^TMP(""SCMCTXT"",$J," ;S @XMTEXT@(0)=""
     146 S DIC="^SCPT(404.43,",BY="[SCMC INACTIVATED]",DHIT="S CNT=$G(CNT)+1,^TMP(""SCMC"",$J,CNT,D0)=""""",CNT=0
     147 S FLDS="",IOP="",DHD="@@",FR=",T-30,,",TO=",,,,," D EN1^DIP
     148 S ^TMP("SCMCTXT",$J,1,0)="There are "_$O(^TMP("SCMC",$J,""),-1)_" Patients Inactivated in last 30 days"
     149 D LINES(2)
     150 D ^XMD
     151 S DISUPNO=1
     152 D PRMAIL^SCMCTSK5(2)
     153 K ^TMP("SCMC",$J),^TMP("SCMCTXT")
     154 I $P($G(^SCTM(404.44,1,1)),U,11)="" D
     155 . S XMSUB="Primary Care Providers Scheduled for Inactivation"
     156 . S XMY("G.PCMM PATIENT/PROVIDER INACTIVE")=""
     157 . K ^TMP("SCMC",$J)
     158 . S XMTEXT="^TMP(""SCMCTXT"",$J,"
     159 . S DIC="^SCTM(404.52,",BY="[SC PROVIDER FLAGGED BULLE]",DHIT="S CNT=$G(CNT)+1,^TMP(""SCMC"",$J,CNT,D0)=""""",CNT=0
     160 . S FLDS="",IOP="",DHD="@@",FR="",TO="" D EN1^DIP
     161 . D LINES(4)
     162 . D ^XMD
     163 . D PRMAIL^SCMCTSK5(4)
     164 . D BULL^SCMCTSK6
     165 Q
     166LINES(TYPE) ;Lines of Bulletin
     167 D LINES^SCMCTSK5(TYPE) Q
     168ROLE(DATA,INFO) ;SCMC ROLE
     169 N ROLE,TP,I
     170 S ROLE=+$G(INFO),TP=+$P($G(INFO),U,2)
     171 S DATA(0)="0^0^0"
     172 I 'ROLE Q
     173 I 'TP Q
     174 S DATA(0)=+$P($G(^SD(403.46,ROLE,0)),U,3) ;I DATA(0)=3!(DATA(0)=0) S DATA(0)=DATA(0)_"^0^0" Q
     175 I $$DATES^SCAPMCU1(404.53,+TP) S DATA(0)=DATA(0)_"^1^0" Q
     176 N PREC S PREC=0
     177 F I=0:0 S I=$O(^SCTM(404.53,"AD",TP,I)) Q:'I  D   Q:PREC
     178 .I $D(^SCTM(404.53,"AD",TP,I,1)) I '$D(^(0)) S PREC=1
     179 I PREC S DATA(0)=DATA(0)_"^0^1" Q
     180 S DATA(0)=DATA(0)_"^0^0"
     181 Q
     182INRPT  ; REPORT
     183 N DIOEND,SCDHD
     184 D PROMPT^SCMCTSK3("**** Date Range Selection ****","DATE PATIENTS INACTIVATED FROM PRIMARY CARE PANELS")
     185 Q:'$D(^TMP("SC",$J,"XR"))
     186 D UNASSIGN^SCMCTSK3
     187 S Q=""""
     188 S DIC="^SCPT(404.43," ;=0,BY="[SCMC INACTIVATION SORT]"
     189 D BY
     190 S (SCDHD,DHD)="AUTOMATED PATIENT INACTIVATION FROM PRIMARY CARE PANELS REPORT"
     191 S DIOBEG="D DIOBEG^SCMCTSK4"
     192 S DIOEND="D DIOEND1^SCMCTSK4"
     193 S FLDS="[SCMC INACTIVATED]" ;,FR="?,,"_$TR(DIPA("SI"),","," "),TO="T,,"_$TR(DIPA("EI")_"z",","," ")
     194 D EN1^DIP
     195 Q
     196IN30 ;inactivated last month
     197 D SORT^SCMCTSK1 Q:'X
     198 S Q=""""
     199 S DIC="^SCPT(404.43,",L=0,BY="[SCMC INACTIVATION SORT]"
     200 S DHD="Patients Inactivated from Primary Care Panels in the Past Month"
     201 S FLDS="[SCMC INACTIVATED]",FR="T-31,,"_$TR(DIPA("SI"),","," "),TO="T,,"_$TR(DIPA("EI")_"z",","," ")
     202 D EN1^DIP
     203 Q
     204EXRPT  ;EXTEND REPORT
     205 K CLIN,TEAM,INST
     206 D PROMPT^SCMCTSK3("PCMM Patients with Extended Inactivations","Scheduled Inactivation Date")
     207 Q:'$D(^TMP("SC",$J,"XR"))
     208 S Q="""",SORT=1
     209 D EXTEND^SCMCTSK3
     210 S DIC="^SCPT(404.43," ;,L=0,BY="[SCMC EXTENDED]"
     211 S (SCDHD,DHD)="PCMM Patients with extended Inactivations"
     212 S DIOBEG="D DIOBEG^SCMCTSK4",DIOEND="D EXTKEY^SCMCTSK9"
     213 D BY
     214 S FLDS="[SCMC EXTENDED]"
     215 D EN1^DIP
     216 Q
     217BY N DISPAR
     218 S BY(0)="^TMP(""SCSORT"",$J)",L(0)=$O(^TMP("SC",$J,"SORT",99),-1)+1,DISPAR(0,1)="+",L=0 I $G(SCDHD)["FTEE" S DISPAR(0,1)="+#" ;BY="@'.01"
     219 F I=1:1:$L(SORTN,U) S A=$P(SORTN,U,I) Q:'$L(A)  S $P(DISPAR(0,I),U,2)=";"_Q_A_": "_Q D
     220 .I A["PATIENT" I (I>1)!($G(SCDHD)["Patients Scheduled for Inactivation from PC Panel") S $P(DISPAR(0,I),U)="@"
     221 .I $G(SCDHD)["FTEE" D
     222 ..I A["PROV" S $P(DISPAR(0,I),U)="@"
     223 ..I I>1 I (A["CLI")!(A["POS") S $P(DISPAR(0,I),U)="@"_$P($G(DISPAR(0,I)),U)
     224 S ZTSAVE("^TMP(""SC"",$J,")="",ZTSAVE("^TMP(""SCSORT"",$J,")=""
     225 Q
     226FLRPT  ;FLAGGED REPORT
     227 D PROMPT^SCMCTSK3("Patients Scheduled for Inactivation from PC Panels","Date Scheduled for Inactivation")
     228 Q:'$D(^TMP("SC",$J,"XR"))
     229 D FLAGG^SCMCTSK3
     230 S Q=""""
     231 S DIC="^SCPT(404.43,",L=0
     232 S (SCDHD,DHD)="Patients Scheduled for Inactivation from PC Panels"
     233 D BY
     234 S DIOBEG="D DIOBEG^SCMCTSK4"
     235 S FLDS="[SCMC PENDING UNASSIGN]"
     236 I $G(DISPAR(0,1))["PATIENT" S FLDS="[SCMC PENDING UNASSIGN PAT]"
     237 S DIOEND="D DIOEND^SCMCTSK4"
     238 D EN1^DIP

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCTSK3.m

    r613 r623  
    1 SCMCTSK3        ;ALB/JDS - PCMM Inactivation Reports ; 7/19/05 10:06am  ; Compiled June 7, 2007 13:57:55  ; Compiled February 12, 2008 11:46:47
    2         ;;5.3;Scheduling;**297,499**;AUG 13, 1993;Build 21
    3         Q
    4 SORTP    ;sort template
    5         N DIC
    6         S DIC=200,DIC(0)="ZME"
    7         S DIC("S")="I $D(^SCTM(404.52,""C"",+Y))"
    8         S DIR("A")="Start with Provider",DIR("B")="FIRST",DIR(0)="F" D ^DIR
    9         I X="FIRST" S DIPA("SP")="",DIPA("EI")="zzz",X=1 Q
    10         D ^DIC I Y<0 S DIPA("SP")=X Q:X[U  D
    11         .S DIR("A")="Go to Provider",DIR("B")="LAST" S DIR(0)="F" D ^DIR
    12         .I X="LAST" S DIPA("EP")="zzz"
    13         I Y>0 S DIPA("SP")=$P(Y(0),U),DIC(0)="AZQME",DIC("A")="Go to Provider: "
    14         D ^DIC
    15         I Y>0 S DIPA("EP")=$P(Y(0),U)
    16         I Y<0 S DIPA("EP")=X Q:X[U
    17         S X=1 Q
    18         Q
    19 KEY     ;Inactivated Report Key
    20         D KEY^SCMCTSK3 Q
    21 SORTYP()               ; sort type
    22         W !,"Sort report by"
    23         S DIR(0)="SO^1:TEAM;2:ASSOCIATED CLINIC;"
    24         S DIR("B")=1
    25         D ^DIR
    26         Q Y
    27 DV(PP)        ;return institution sort of patient assignment entry and then IEN of team^ien of position
    28         N A,B,C,T,I,INSTNM,INSTN
    29         S A=$G(^SCPT(404.43,+PP,0)),T=+$P($G(^SCPT(404.42,+A,0)),U,3) I $D(INST(T)) Q INST(T)_U_T_U_$P(A,U,2)
    30         S I=$P($G(^SCTM(404.51,T,0)),U,7) I $O(^TMP("SC",$J,"DIV",0)) I '$D(^TMP("SC",$J,"DIV",I)) Q -1
    31         S INSTNM=$$GET1^DIQ(4,(+I)_",",.01),INSTN=$$GET1^DIQ(4,(+I)_",",99)
    32         S INST(T)=$S($L(INSTN)=3:INSTN_" ",1:"")_INSTNM Q INST(T)_U_T_U_$P(A,U,2)
    33 EC(PP)      ;return enrolled clinics
    34         N I,A
    35         S A=""
    36         F I=0:0 S I=$O(^SCTM(404.57,+$P(ZERO,U,2),5,I)) Q:'I  D
    37         .I '$$PTCL^SCRPO2(DFN,U_I,0,DT) Q   ;not enrolled
    38         .I $D(CLIN(I)) S A=A_CLIN(I)_U Q
    39         .I $O(^TMP("SC",$J,"CLINIC",0)) I '$D(^(I)) Q
    40         .S CLIN(I)=$P($G(^SC(I,0)),U) I $L(CLIN(I)) S A=A_CLIN(I)_U
    41         Q $S(A="":-1,1:A)
    42 TM(PP)  ;Return Team
    43         N I,A,T
    44         S T=+$P($G(^SCPT(404.42,+ZERO,0)),U,3)
    45         I $D(TEAM(T)) Q TEAM(T)
    46         I $O(^TMP("SC",$J,"TEAM",0)) I '$D(^(T)) Q -1
    47         S TEAM(T)=$P($G(^SCTM(404.51,+T,0)),U)
    48         I '$L(TEAM(T)) K TEAM(T) Q -1
    49         Q TEAM(T)
    50 IU(DFN) ;is patient inactivity unassigned
    51         N I,A,B,DATA,QUIT
    52         S DATA=-1,QUIT=0
    53         F I=0:0 S I=$O(^SCPT(404.42,"B",+$G(DFN),I)) Q:'I  S A=$G(^SCPT(404.42,I,0)) D  Q:QUIT
    54         .F J=0:0 S J=$O(^SCPT(404.43,"B",I,J)) Q:'J  S B=$G(^SCPT(404.43,+J,0)) D  Q:QUIT
    55         ..I $P(B,U,5),'$P(B,U,4) K A S QUIT=1 Q
    56         ..I $P(B,U,12)="NA" S POS=+J D
    57         ...S A("IU",I)=A
    58         ...S A("IUA")=A
    59         ...S A("IUB")=B
    60         ...I $P(A,U,8),'$P(A,U,9) S A("A")=1
    61         ;Q:$D(A("A")) DATA
    62         Q:'$D(A("IU")) DATA
    63         ;S DATA="1~"_$P(^SCTM(404.51,+$P(A,U,3),0),U)_"~"_(+$P(A,U,3))_"~"_$P($G(^SCTM(404.57,+$P(B,U,2),0)),U)_"~"_($P(B,U,2))_"~"_POS
    64         S DATA="1~"_$P(^SCTM(404.51,+$P(A("IUA"),U,3),0),U)_"~"_(+$P(A("IUA"),U,3))_"~"_$P($G(^SCTM(404.57,+$P(A("IUB"),U,2),0)),U)_"~"_($P(A("IUB"),U,2))_"~"_POS
    65         Q DATA
    66 PROMPT(SCDESC,DATESORT) ;Prompt for report parameters, queue report
    67         ;Input: LIST=comma delimited string of list subscripts to prompt for
    68         ;Input: SCRTN=report routine entry point
    69         ;Input: SCDESC=tasked job description
    70         ;
    71         K TEAM,CLIN,INST,^TMP("SCSORT",$J)
    72         N SCDIV,SCBDT,SCEDT,SC,SCI,SCX,SCOUT,SCT
    73         D HOME^%ZIS
    74         D ENS^%ZISS
    75         S SC="^TMP(""SC"",$J)" K @SC S SCOUT=0
    76         D TITL^SCRPW50(SCDESC)
    77         I $L($G(DATESORT)) D  G:'$$DTR^SCRPO(.SC,.SCBDT,.SCEDT) END
    78         .D SUBT^SCRPW50(DATESORT)
    79         .S SCBDT("B")="T-30",SCEDT("B")="TODAY"
    80         .I (DATESORT["Scheduled Ina")!(DATESORT["Scheduled for Inactivation") S SCEDT("B")="T+60"
    81         S LIST="DIV,TEAM,POS,ASPR"
    82         ;D SUBT^SCRPW50("**** Date Range Selection ****")
    83         ;S (SCBDT("B"),SCEDT("B"))="TODAY"
    84         ;G:'$$DTR^SCRPO(.SC,.SCBDT,.SCEDT) END
    85         ;D SUBT^SCRPW50("**** Report Parameter Selection ****")
    86         F SCI=1:1:$L(LIST,",") S SCX=$P(LIST,",",SCI) D  Q:SCOUT
    87         .S SCOUT='$$LIST^SCRPO(.SC,SCX,1)
    88         .Q
    89         G:SCOUT END
    90         S SORT="DV,TM,TP,PR"_$S(SCDESC["FTEE":",AC",1:",PT")
    91         D SUBT^SCRPW50("**** Output sort order (optional) ****")
    92         G:'$$SORT^SCRPO(.SC,SORT,"") END
    93         S SCT(1)="**** Report Parameters Selected ****" D SUBT^SCRPW50(SCT(1))
    94         G:'$$PPAR^SCRPO(.SC,1,.SCT) END
    95         S SORTN=""
    96         F SCI=0:0 S SCI=$O(^TMP("SC",$J,"SORT",SCI)) Q:'SCI  S SORTN=SORTN_$P(^(SCI),U,2)_U
    97         W:$G(IORESET)'[$C(99) $G(IORESET)
    98         Q
    99 END     W:$G(IORESET)'[$C(99) $G(IORESET) K ^TMP("SC",$J) Q
    100 EXTEND  ;Sort Extend
    101         K ^TMP("SCSORT",$J)
    102         I '$D(^TMP("SC",$J,"SORT",1)) S ^(1)="DV^INSTITUTION^SCDIV",SORTN="DIVISION"
    103         N SORT S A="" F  S A=$O(^TMP("SC",$J,A)) Q:A=""  I "XRSORTDTR"'[A I $G(^(A))'="ALL" S SORT($S(A="ASPR":"PR",A="DIV":"DV",A="POS":"TP",1:"TM",A="PATIENT":PT))=""
    104         N I,A,ED,SD
    105         F I=0:0 S I=$O(^SCPT(404.43,"AEXT",I)) Q:'I  F J=0:0 S J=$O(^SCPT(404.43,"AEXT",I,J)) Q:'J  D
    106         .I '$P($G(^SCPT(404.43,J,0)),U,15) Q
    107         .S SD=$G(^TMP("SC",$J,"DTR","BEGIN")) I SD S ED=$G(^("END")) S:'ED ED=9999999 D INACTDT^SCMCTSK1(J) I (X<SD)!(X>ED) Q
    108         .D SORT(0)
    109         Q
    110 FILEIN(DATA,INFO)       ;undo a inactivation
    111         ;INFO entry in PATIENT POSITION ASSIGNMENT file
    112         N ZERO,FLDA S DATA=1
    113         S ZERO=$G(^SCPT(404.43,+$G(INFO),0))
    114         ;I $P(ZERO,U,12)'="IU" Q
    115         S FLDA(404.43,(+INFO)_",",.12)=""
    116         S FLDA(404.43,(+INFO)_",",.04)=""
    117         S FLDA(404.43,(+INFO)_",",.15)=""
    118         S FLDA(404.43,(+INFO)_",",.17)=DT
    119         I $D(^SCPT(404.42,+ZERO,0)) S FLDA(404.42,(+ZERO)_",",.15)="",FLDA(404.42,(+ZERO)_",",.09)=""
    120         D FILE^DIE("E","FLDA","ERR")
    121         Q
    122 UNASSIGN         ;Sort UNASSIGNMENTS
    123         N END,START
    124         K ^TMP("SCSORT",$J)
    125         S START=$G(^TMP("SC",$J,"DTR","BEGIN"))-.1,END=$G(^("END"))+.9
    126         I '$D(^TMP("SC",$J,"SORT",1)) S ^(1)="DV^INSTITUTION^SCDIV",SORTN="INSTITUTION"
    127         N I,A,STAT
    128         F STAT="NA","DU" F J=0:0 S J=$O(^SCPT(404.43,"ASTATB",STAT,J)) Q:'J  D
    129         .S ZERO=$G(^SCPT(404.43,J,0)) I ($P(ZERO,U,4)<START)!($P(ZERO,U,4)>END) Q
    130         .D SORT(1)
    131         Q
    132 DFN(A)  ;Return patient from Position assigment
    133         Q +$G(^SCPT(404.42,+$G(A),0))
    134 PA(A)   ;return patient name
    135         Q $P($G(^DPT(+$G(DFN),0)),U)
    136 PR(PP)   ;Return assigned provider
    137         N A
    138         S A=$$GETPRTP^SCAPMCU2(+$P(ZERO,U,2),DT)
    139         I $O(^TMP("SC",$J,"ASPR",0)) I '$D(^(+A)) Q -1
    140         S A=$P(A,U,2)
    141         Q $S(A="":-1,1:A)
    142 TP(A)   ;return the team position
    143         N TP S TP=+$P($G(ZERO),U,2)
    144         I $O(^TMP("SC",$J,"POS",0)) I '$D(^(TP)) Q -1
    145         Q $P($G(^SCTM(404.57,+TP,0)),U)
    146 FLAGG   ;Sort FLAGGED
    147         K ^TMP("SCSORT",$J)
    148         N I,A,J
    149         I '$D(^TMP("SC",$J,"SORT",1)) S ^(1)="DV^INSTITUTION^SCDIV",SORTN="INSTITUTION",^(2)="TM^TEAM^SCTEAM",^(3)="PR^PROVIDER^SCPROV",^(4)="PA^PATIENT^SCPAT"
    150         N SORT S A="" F  S A=$O(^TMP("SC",$J,A)) Q:A=""  I "XRSORTDTR"'[A I $G(^(A))'="ALL" S SORT($S(A="ASPR":"PR",A="DIV":"DV",A="POS":"TP",1:"TM",A="PATIENT":PT))=""
    151         S SDT=$G(^TMP("SC",$J,"DTR","BEGIN")),END=$G(^("END"))+.9
    152         F I=0:0 S I=$O(^SCPT(404.43,"AFLG",I)) Q:'I  F J=0:0 S J=$O(^SCPT(404.43,"AFLG",I,J)) Q:'J  D
    153         .I SDT>0 S:(END'>9) END=9999999 D INACTDT^SCMCTSK1(J) I (X<SDT)!(X>END) Q
    154         .D SORT(0)
    155         Q
    156 SORT(INACTIVE)   ;
    157         N A,B,C,D,E,QUIT,SCA,K,KCNT,PIECE
    158         S ZERO=$G(^SCPT(404.43,+J,0)) Q:$S('$G(INACTIVE):$P(ZERO,U,4),1:'$P(ZERO,U,4))
    159         S DFN=$$DFN(+ZERO)
    160         S QUIT=0,KCNT=0
    161         F K=1:1 Q:'$D(^TMP("SC",$J,"SORT",K))  S A=^(K) K SORT($P(A,U)) S @("A("_K_")=$$"_$P(A,U)_"("_J_")") D  I (A(K)=-1)!($P(A(K),U)="") S QUIT=1 Q
    162         .I $P(A,U)="EC",$L(A(K),U)>2 S KCNT=K
    163         Q:QUIT
    164         S A="" F  S A=$O(SORT(A)) Q:A=""  S @("B=$$"_A_"("_J_")") I B=-1 S QUIT=1 Q
    165         Q:QUIT
    166         F PIECE=1:1:$S(KCNT:$L(A(KCNT),U)-1,1:1) D
    167         .S B="E" K @B
    168         .F K=1:1:$O(A(99),-1) S @B@($P(A(K),U,$S(K=KCNT:PIECE,1:1)))="" S C=$Q(@B) K @B S B=C
    169         .S @B@(J)=""
    170         .M ^TMP("SCSORT",$J)=E
    171         Q
    172 INACT   ;
    173         N ALPHA,ZERO
    174         S ALPHA=$G(^SCTM(404.44,1,1)),ALPHA=$P(ALPHA,U,8) I ALPHA<DT S ALPHA=0
    175         S ZERO=$G(^SCPT(404.43,+$G(PA),0)) I '$P(ZERO,U,15) S X="" Q
    176         S X1=$P(ZERO,U,15),X2=$S(ALPHA:2,1:30) I $P(ZERO,U,13) S X2=$S(ALPHA:5,1:90)
    177         D C^%DTC Q:ALPHA  Q:$E(X,6,7)=15
    178         F  S (ZERO,X1)=X,X2=1 D C^%DTC Q:$E(X,6,7)=15  I $E(X,6,7)="01" S X=ZERO Q
    179         Q
    180 INCON   ;Inconsistency
    181         N X
    182         F POS=0:0 S POS=$O(^SCTM(404.57,POS)) Q:'POS  D POSIN(POS) I $L(X) S ^TMP("SCMCTSK",$J,POS)=X
    183         Q
    184 POSIN(POS)           ;
    185         S X=""
    186         N ZERO S ZERO=$G(^SCTM(404.57,POS,0))
    187         I '$P(ZERO,U,4) Q   ;not primary care ignore this
    188         I '$$ACTTP^SCMCTPU(POS) Q  ;inactive position   
    189         I '$$OKPREC3^SCMCLK(POS,DT) I '$P($G(^SD(403.46,+$P(ZERO,U,3),0)),U,3) S X="Role not=PCprovider" Q
    190         ;find provider assigned to position and their person class
    191         S PROV=+$$GETPRTP^SCAPMCU2(POS,DT) Q:'PROV
    192         S PC=$$GET^XUA4A72(+PROV)
    193         I '$O(^SD(403.46,+$P(ZERO,U,3),2,0)) Q
    194         I '$D(^SD(403.46,+$P(ZERO,U,3),2,+PC)) S X="PersonClass not valid"
    195         Q
    196 PRFLAG  ;
    197         N LASTDT,POSH
    198         K ^TMP("SCMCTSK",$J) N FLDA
    199         F POS=0:0 S POS=$O(^SCTM(404.57,POS)) Q:'POS  S ZERO=$G(^(POS,0)) D
    200         .I '$P(ZERO,U,4) Q   ;not primary care ignore this
    201         .I '$$ACTTP^SCMCTPU(POS) Q  ;inactive position
    202         .S LASTDT=+$O(^SCTM(404.52,"AIDT",POS,1,-DT)),POSH=+$O(^SCTM(404.52,"AIDT",POS,1,LASTDT,0)) Q:'POSH
    203         .I $O(^SCTM(404.52,"AIDT",POS,0,-9999999))<LASTDT Q   ;inactivation already scheduled
    204         .I $P($G(^SCTM(404.52,POSH,0)),U,10) S FLDA(404.52,POSH_",",.091)="" ;already flagged
    205         .I '$P($G(^SCTM(404.52,POSH,0)),U,4) Q   ;inactive
    206         .I '$$OKPREC3^SCMCLK(POS,DT) I '$P($G(^SD(403.46,+$P(ZERO,U,3),0)),U,3) S ^TMP("SCMCTSK",$J,POSH)="Role cannot be primary care" Q
    207         .;find provider assigned to position and their person class
    208         .S PROV=+$$GETPRTP^SCAPMCU2(POS,DT)
    209         .S PC=$$GET^XUA4A72(+PROV)
    210         .I '$D(^SD(403.46,+$P(ZERO,U,3),2,+PC)) S ^TMP("SCMCTSK",$J,POSH)="Person Class is not valid for this role"
    211         F POS=0:0 S POS=$O(^TMP("SCMCTSK",$J,POS)) Q:'POS  S FLDA(404.52,POS_",",.091)=DT
    212 VERPR   ;verify already flagged positions; SD/499 replaced "AFLG" with "AFLAG"
    213         N II,POSH S II="" F  S II=$O(^SCTM(404.52,"AFLAG",II)) Q:'II  S POSH=""  F  S POSH=$O(^SCTM(404.52,"AFLAG",II,POSH)) Q:'POSH  D
    214         .N ZERO,ZEROTP S ZERO=$G(^SCTM(404.52,POSH,0))
    215         .I '$P(ZERO,U,4) S FLDA(404.52,POSH_",",.091)="" Q
    216         .;SD/499; added verification of the POSSIBLE PRIMARY PRACTITIONER field
    217         .;in the TEAM POSITION file
    218         .N TP S TP=$P(ZERO,U) S ZEROTP=$G(^SCTM(404.57,TP,0))
    219         .I '$P(ZEROTP,U,4) S FLDA(404.52,POSH_",",.091)="" Q
    220         .I (-$O(^SCTM(404.52,"AIDT",+ZERO,0,-9999999)))>$P(ZERO,U,2) S FLDA(404.52,POSH_",",.091)=""
    221         I $O(FLDA(0)) D FILE^DIE("I","FLDA","ERR")
    222         K ^TMP("SCMCTSK",$J)
    223         Q
     1SCMCTSK3 ;ALB/JDS - PCMM Inactivation Reports ; 7/19/05 10:06am
     2 ;;5.3;Scheduling;**297**;AUG 13, 1993
     3 Q
     4SORTP  ;sort template
     5 N DIC
     6 S DIC=200,DIC(0)="ZME"
     7 S DIC("S")="I $D(^SCTM(404.52,""C"",+Y))"
     8 S DIR("A")="Start with Provider",DIR("B")="FIRST",DIR(0)="F" D ^DIR
     9 I X="FIRST" S DIPA("SP")="",DIPA("EI")="zzz",X=1 Q
     10 D ^DIC I Y<0 S DIPA("SP")=X Q:X[U  D
     11 .S DIR("A")="Go to Provider",DIR("B")="LAST" S DIR(0)="F" D ^DIR
     12 .I X="LAST" S DIPA("EP")="zzz"
     13 I Y>0 S DIPA("SP")=$P(Y(0),U),DIC(0)="AZQME",DIC("A")="Go to Provider: "
     14 D ^DIC
     15 I Y>0 S DIPA("EP")=$P(Y(0),U)
     16 I Y<0 S DIPA("EP")=X Q:X[U
     17 S X=1 Q
     18 Q
     19KEY ;Inactivated Report Key
     20 D KEY^SCMCTSK3 Q
     21SORTYP()        ; sort type
     22 W !,"Sort report by"
     23 S DIR(0)="SO^1:TEAM;2:ASSOCIATED CLINIC;"
     24 S DIR("B")=1
     25 D ^DIR
     26 Q Y
     27DV(PP)       ;return institution sort of patient assignment entry and then IEN of team^ien of position
     28 N A,B,C,T,I,INSTNM,INSTN
     29 S A=$G(^SCPT(404.43,+PP,0)),T=+$P($G(^SCPT(404.42,+A,0)),U,3) I $D(INST(T)) Q INST(T)_U_T_U_$P(A,U,2)
     30 S I=$P($G(^SCTM(404.51,T,0)),U,7) I $O(^TMP("SC",$J,"DIV",0)) I '$D(^TMP("SC",$J,"DIV",I)) Q -1
     31 S INSTNM=$$GET1^DIQ(4,(+I)_",",.01),INSTN=$$GET1^DIQ(4,(+I)_",",99)
     32 S INST(T)=$S($L(INSTN)=3:INSTN_" ",1:"")_INSTNM Q INST(T)_U_T_U_$P(A,U,2)
     33EC(PP)     ;return enrolled clinics
     34 N I,A
     35 S A=""
     36 F I=0:0 S I=$O(^SCTM(404.57,+$P(ZERO,U,2),5,I)) Q:'I  D
     37 .I '$$PTCL^SCRPO2(DFN,U_I,0,DT) Q   ;not enrolled
     38 .I $D(CLIN(I)) S A=A_CLIN(I)_U Q
     39 .I $O(^TMP("SC",$J,"CLINIC",0)) I '$D(^(I)) Q
     40 .S CLIN(I)=$P($G(^SC(I,0)),U) I $L(CLIN(I)) S A=A_CLIN(I)_U
     41 Q $S(A="":-1,1:A)
     42TM(PP) ;Return Team
     43 N I,A,T
     44 S T=+$P($G(^SCPT(404.42,+ZERO,0)),U,3)
     45 I $D(TEAM(T)) Q TEAM(T)
     46 I $O(^TMP("SC",$J,"TEAM",0)) I '$D(^(T)) Q -1
     47 S TEAM(T)=$P($G(^SCTM(404.51,+T,0)),U)
     48 I '$L(TEAM(T)) K TEAM(T) Q -1
     49 Q TEAM(T)
     50IU(DFN) ;is patient inactivity unassigned
     51 N I,A,B,DATA,QUIT
     52 S DATA=-1,QUIT=0
     53 F I=0:0 S I=$O(^SCPT(404.42,"B",+$G(DFN),I)) Q:'I  S A=$G(^SCPT(404.42,I,0)) D  Q:QUIT
     54 .F J=0:0 S J=$O(^SCPT(404.43,"B",I,J)) Q:'J  S B=$G(^SCPT(404.43,+J,0)) D  Q:QUIT
     55 ..I $P(B,U,5),'$P(B,U,4) K A S QUIT=1 Q
     56 ..I $P(B,U,12)="NA" S POS=+J D
     57 ...S A("IU",I)=A
     58 ...S A("IUA")=A
     59 ...S A("IUB")=B
     60 ...I $P(A,U,8),'$P(A,U,9) S A("A")=1
     61 ;Q:$D(A("A")) DATA
     62 Q:'$D(A("IU")) DATA
     63 ;S DATA="1~"_$P(^SCTM(404.51,+$P(A,U,3),0),U)_"~"_(+$P(A,U,3))_"~"_$P($G(^SCTM(404.57,+$P(B,U,2),0)),U)_"~"_($P(B,U,2))_"~"_POS
     64 S DATA="1~"_$P(^SCTM(404.51,+$P(A("IUA"),U,3),0),U)_"~"_(+$P(A("IUA"),U,3))_"~"_$P($G(^SCTM(404.57,+$P(A("IUB"),U,2),0)),U)_"~"_($P(A("IUB"),U,2))_"~"_POS
     65 Q DATA
     66PROMPT(SCDESC,DATESORT) ;Prompt for report parameters, queue report
     67 ;Input: LIST=comma delimited string of list subscripts to prompt for
     68 ;Input: SCRTN=report routine entry point
     69 ;Input: SCDESC=tasked job description
     70 ;
     71 K TEAM,CLIN,INST,^TMP("SCSORT",$J)
     72 N SCDIV,SCBDT,SCEDT,SC,SCI,SCX,SCOUT,SCT
     73 D HOME^%ZIS
     74 D ENS^%ZISS
     75 S SC="^TMP(""SC"",$J)" K @SC S SCOUT=0
     76 D TITL^SCRPW50(SCDESC)
     77 I $L($G(DATESORT)) D  G:'$$DTR^SCRPO(.SC,.SCBDT,.SCEDT) END
     78 .D SUBT^SCRPW50(DATESORT)
     79 .S SCBDT("B")="T-30",SCEDT("B")="TODAY"
     80 .I (DATESORT["Scheduled Ina")!(DATESORT["Scheduled for Inactivation") S SCEDT("B")="T+30"
     81 S LIST="DIV,TEAM,POS,ASPR"
     82 ;D SUBT^SCRPW50("**** Date Range Selection ****")
     83 ;S (SCBDT("B"),SCEDT("B"))="TODAY"
     84 ;G:'$$DTR^SCRPO(.SC,.SCBDT,.SCEDT) END
     85 ;D SUBT^SCRPW50("**** Report Parameter Selection ****")
     86 F SCI=1:1:$L(LIST,",") S SCX=$P(LIST,",",SCI) D  Q:SCOUT
     87 .S SCOUT='$$LIST^SCRPO(.SC,SCX,1)
     88 .Q
     89 G:SCOUT END
     90 S SORT="DV,TM,TP,PR"_$S(SCDESC["FTEE":",AC",1:",PT")
     91 D SUBT^SCRPW50("**** Output sort order (optional) ****")
     92 G:'$$SORT^SCRPO(.SC,SORT,"") END
     93 S SCT(1)="**** Report Parameters Selected ****" D SUBT^SCRPW50(SCT(1))
     94 G:'$$PPAR^SCRPO(.SC,1,.SCT) END
     95 S SORTN=""
     96 F SCI=0:0 S SCI=$O(^TMP("SC",$J,"SORT",SCI)) Q:'SCI  S SORTN=SORTN_$P(^(SCI),U,2)_U
     97 W:$G(IORESET)'[$C(99) $G(IORESET)
     98 Q
     99END W:$G(IORESET)'[$C(99) $G(IORESET) K ^TMP("SC",$J) Q
     100EXTEND ;Sort Extend
     101 K ^TMP("SCSORT",$J)
     102 I '$D(^TMP("SC",$J,"SORT",1)) S ^(1)="DV^INSTITUTION^SCDIV",SORTN="DIVISION"
     103 N SORT S A="" F  S A=$O(^TMP("SC",$J,A)) Q:A=""  I "XRSORTDTR"'[A I $G(^(A))'="ALL" S SORT($S(A="ASPR":"PR",A="DIV":"DV",A="POS":"TP",1:"TM",A="PATIENT":PT))=""
     104 N I,A,ED,SD
     105 F I=0:0 S I=$O(^SCPT(404.43,"AEXT",I)) Q:'I  F J=0:0 S J=$O(^SCPT(404.43,"AEXT",I,J)) Q:'J  D
     106 .I '$P($G(^SCPT(404.43,J,0)),U,15) Q
     107 .S SD=$G(^TMP("SC",$J,"DTR","BEGIN")) I SD S ED=$G(^("END")) S:'ED ED=9999999 D INACTDT^SCMCTSK1(J) I (X<SD)!(X>ED) Q
     108 .D SORT(0)
     109 Q
     110FILEIN(DATA,INFO) ;undo a inactivation
     111 ;INFO entry in PATIENT POSITION ASSIGNMENT file
     112 N ZERO,FLDA S DATA=1
     113 S ZERO=$G(^SCPT(404.43,+$G(INFO),0))
     114 ;I $P(ZERO,U,12)'="IU" Q
     115 S FLDA(404.43,(+INFO)_",",.12)=""
     116 S FLDA(404.43,(+INFO)_",",.04)=""
     117 S FLDA(404.43,(+INFO)_",",.15)=""
     118 S FLDA(404.43,(+INFO)_",",.17)=DT
     119 I $D(^SCPT(404.42,+ZERO,0)) S FLDA(404.42,(+ZERO)_",",.15)="",FLDA(404.42,(+ZERO)_",",.09)=""
     120 D FILE^DIE("E","FLDA","ERR")
     121 Q
     122UNASSIGN  ;Sort UNASSIGNMENTS
     123 N END,START
     124 K ^TMP("SCSORT",$J)
     125 S START=$G(^TMP("SC",$J,"DTR","BEGIN"))-.1,END=$G(^("END"))+.9
     126 I '$D(^TMP("SC",$J,"SORT",1)) S ^(1)="DV^INSTITUTION^SCDIV",SORTN="INSTITUTION"
     127 N I,A,STAT
     128 F STAT="NA","DU" F J=0:0 S J=$O(^SCPT(404.43,"ASTATB",STAT,J)) Q:'J  D
     129 .S ZERO=$G(^SCPT(404.43,J,0)) I ($P(ZERO,U,4)<START)!($P(ZERO,U,4)>END) Q
     130 .D SORT(1)
     131 Q
     132DFN(A) ;Return patient from Position assigment
     133 Q +$G(^SCPT(404.42,+$G(A),0))
     134PA(A) ;return patient name
     135 Q $P($G(^DPT(+$G(DFN),0)),U)
     136PR(PP)  ;Return assigned provider
     137 N A
     138 S A=$$GETPRTP^SCAPMCU2(+$P(ZERO,U,2),DT)
     139 I $O(^TMP("SC",$J,"ASPR",0)) I '$D(^(+A)) Q -1
     140 S A=$P(A,U,2)
     141 Q $S(A="":-1,1:A)
     142TP(A) ;return the team position
     143 N TP S TP=+$P($G(ZERO),U,2)
     144 I $O(^TMP("SC",$J,"POS",0)) I '$D(^(TP)) Q -1
     145 Q $P($G(^SCTM(404.57,+TP,0)),U)
     146FLAGG ;Sort FLAGGED
     147 K ^TMP("SCSORT",$J)
     148 N I,A,J
     149 I '$D(^TMP("SC",$J,"SORT",1)) S ^(1)="DV^INSTITUTION^SCDIV",SORTN="INSTITUTION",^(2)="TM^TEAM^SCTEAM",^(3)="PR^PROVIDER^SCPROV",^(4)="PA^PATIENT^SCPAT"
     150 N SORT S A="" F  S A=$O(^TMP("SC",$J,A)) Q:A=""  I "XRSORTDTR"'[A I $G(^(A))'="ALL" S SORT($S(A="ASPR":"PR",A="DIV":"DV",A="POS":"TP",1:"TM",A="PATIENT":PT))=""
     151 S SDT=$G(^TMP("SC",$J,"DTR","BEGIN")),END=$G(^("END"))+.9
     152 F I=0:0 S I=$O(^SCPT(404.43,"AFLG",I)) Q:'I  F J=0:0 S J=$O(^SCPT(404.43,"AFLG",I,J)) Q:'J  D
     153 .I SDT>0 S:(END'>9) END=9999999 D INACTDT^SCMCTSK1(J) I (X<SDT)!(X>END) Q
     154 .D SORT(0)
     155 Q
     156SORT(INACTIVE)  ;
     157 N A,B,C,D,E,QUIT,SCA,K,KCNT,PIECE
     158 S ZERO=$G(^SCPT(404.43,+J,0)) Q:$S('$G(INACTIVE):$P(ZERO,U,4),1:'$P(ZERO,U,4))
     159 S DFN=$$DFN(+ZERO)
     160 S QUIT=0,KCNT=0
     161 F K=1:1 Q:'$D(^TMP("SC",$J,"SORT",K))  S A=^(K) K SORT($P(A,U)) S @("A("_K_")=$$"_$P(A,U)_"("_J_")") D  I (A(K)=-1)!($P(A(K),U)="") S QUIT=1 Q
     162 .I $P(A,U)="EC",$L(A(K),U)>2 S KCNT=K
     163 Q:QUIT
     164 S A="" F  S A=$O(SORT(A)) Q:A=""  S @("B=$$"_A_"("_J_")") I B=-1 S QUIT=1 Q
     165 Q:QUIT
     166 F PIECE=1:1:$S(KCNT:$L(A(KCNT),U)-1,1:1) D
     167 .S B="E" K @B
     168 .F K=1:1:$O(A(99),-1) S @B@($P(A(K),U,$S(K=KCNT:PIECE,1:1)))="" S C=$Q(@B) K @B S B=C
     169 .S @B@(J)=""
     170 .M ^TMP("SCSORT",$J)=E
     171 Q
     172INACT ;
     173 N ALPHA,ZERO
     174 S ALPHA=$G(^SCTM(404.44,1,1)),ALPHA=$P(ALPHA,U,8) I ALPHA<DT S ALPHA=0
     175 S ZERO=$G(^SCPT(404.43,+$G(PA),0)) I '$P(ZERO,U,15) S X="" Q
     176 S X1=$P(ZERO,U,15),X2=$S(ALPHA:2,1:30) I $P(ZERO,U,13) S X2=$S(ALPHA:5,1:90)
     177 D C^%DTC Q:ALPHA  Q:$E(X,6,7)=15
     178 F  S (ZERO,X1)=X,X2=1 D C^%DTC Q:$E(X,6,7)=15  I $E(X,6,7)="01" S X=ZERO Q
     179 Q
     180INCON ;Inconsistency
     181 N X
     182 F POS=0:0 S POS=$O(^SCTM(404.57,POS)) Q:'POS  D POSIN(POS) I $L(X) S ^TMP("SCMCTSK",$J,POS)=X
     183 Q
     184POSIN(POS)      ;
     185 S X=""
     186 N ZERO S ZERO=$G(^SCTM(404.57,POS,0))
     187 I '$P(ZERO,U,4) Q   ;not primary care ignore this
     188 I '$$ACTTP^SCMCTPU(POS) Q  ;inactive position   
     189 I '$$OKPREC3^SCMCLK(POS,DT) I '$P($G(^SD(403.46,+$P(ZERO,U,3),0)),U,3) S X="Role not=PCprovider" Q
     190 ;find provider assigned to position and their person class
     191 S PROV=+$$GETPRTP^SCAPMCU2(POS,DT) Q:'PROV
     192 S PC=$$GET^XUA4A72(+PROV)
     193 I '$O(^SD(403.46,+$P(ZERO,U,3),2,0)) Q
     194 I '$D(^SD(403.46,+$P(ZERO,U,3),2,+PC)) S X="PersonClass not valid"
     195 Q
     196PRFLAG ;
     197 N LASTDT,POSH
     198 K ^TMP("SCMCTSK",$J) N FLDA
     199 F POS=0:0 S POS=$O(^SCTM(404.57,POS)) Q:'POS  S ZERO=$G(^(POS,0)) D
     200 .I '$P(ZERO,U,4) Q   ;not primary care ignore this
     201 .I '$$ACTTP^SCMCTPU(POS) Q  ;inactive position
     202 .S LASTDT=+$O(^SCTM(404.52,"AIDT",POS,1,-DT)),POSH=+$O(^SCTM(404.52,"AIDT",POS,1,LASTDT,0)) Q:'POSH
     203 .I $O(^SCTM(404.52,"AIDT",POS,0,-9999999))<LASTDT Q   ;inactivation already scheduled
     204 .I $P($G(^SCTM(404.52,POSH,0)),U,10) S FLDA(404.52,POSH_",",.091)="" ;already flagged
     205 .I '$P($G(^SCTM(404.52,POSH,0)),U,4) Q   ;inactive
     206 .I '$$OKPREC3^SCMCLK(POS,DT) I '$P($G(^SD(403.46,+$P(ZERO,U,3),0)),U,3) S ^TMP("SCMCTSK",$J,POSH)="Role cannot be primary care" Q
     207 .;find provider assigned to position and their person class
     208 .S PROV=+$$GETPRTP^SCAPMCU2(POS,DT)
     209 .S PC=$$GET^XUA4A72(+PROV)
     210 .I '$D(^SD(403.46,+$P(ZERO,U,3),2,+PC)) S ^TMP("SCMCTSK",$J,POSH)="Person Class is not valid for this role"
     211 F POS=0:0 S POS=$O(^TMP("SCMCTSK",$J,POS)) Q:'POS  S FLDA(404.52,POS_",",.091)=DT
     212 F I=0:0 S I=$O(^SCTM(404.52,"AFLG",I)) Q:'I  F POSH=0:0 S POSH=$O(^SCTM(404.52,"AFLG",I,POSH)) Q:'POSH  D
     213 .N ZERO S ZERO=$G(^SCTM(404.52,POSH,0))
     214 .I '$P(ZERO,U,4) S FLDA(404.52,POSH_",",.091)="" Q
     215 .I (-$O(^SCTM(404.52,"AIDT",+ZERO,0,-9999999)))>$P(ZERO,U,2) S FLDA(404.52,POSH_",",.091)=""
     216 I $O(FLDA(0)) D FILE^DIE("I","FLDA","ERR")
     217 K ^TMP("SCMCTSK",$J)
     218 Q

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCTSK4.m

    r613 r623  
    1 SCMCTSK4        ;ALB/JDS - PCMM Inactivation Reports ; 18 Apr 2003  9:36 AM
    2         ;;5.3;Scheduling;**297,526**;AUG 13, 1993;Build 8
    3         Q
    4 POSCHK  ;
    5         N NAME S NAME=$P($G(^SD(403.46,+$P(INFO,U,3),0)),U)
    6         I "RESIDENT (PHYSICIAN)INTERN (PHYSICIAN)"[NAME S $P(DATA,U,3)=1 Q
    7         I "NURSE PRACTITIONERPHYSICIAN ASSISTANT"[NAME S $P(DATA,U,3)=2 Q
    8         I "PHYSICIAN-ATTENDINGPHYSICIAN-PRIMARY CARENURSE PRACTITIONERPHYSICIAN ASSISTANTPHYSICIAN-PSYCHIATRIST"[NAME D  Q
    9         .S $P(DATA,U,3)=3
    10         Q
    11 DIOBEG  ;
    12         N PG,DC
    13         N Y,% W @IOF,!,$G(SCDHD) D NOW^%DTC S Y=% W:$X>(IOM-40) ! W ?(IOM-40)
    14         W $P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$E(Y,4,5))_" " W:Y#100 $J(Y#100\1,2)_"," W Y\10000+1700 W:Y#1 "  "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12)
    15         W ?(IOM-15),"PAGE: 1"
    16         S Y="",$P(Y,"-",IOM)="" W !,Y,!!
    17         W ?(IOM/2-24),"**** Report Parameters Selected ****",!
    18         S SC="^TMP(""SC"",$J)"
    19         S X=$$PPAR^SCMCTSK8(.SC,.SCT)
    20         S (PG,DC)=1
    21         F  Q:$Y>(IOSL-3)  W !
    22         ;I IOST["C" W !! R SCX:DT I SCX[U S DIOUT=1
    23         Q
    24 DIOEND  ;print key
    25         N Y,% W @IOF,!,$G(SCDHD) D NOW^%DTC S Y=% W:$X>(IOM-40) ! W ?(IOM-40)
    26         W $P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$E(Y,4,5))_" " W:Y#100 $J(Y#100\1,2)_"," W Y\10000+1700 W:Y#1 "  "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12)
    27         W ?(IOM-15),"PAGE: "_($G(DC)+1)
    28         S Y="",$P(Y,"-",IOM)="" W !,Y,!!
    29         W !,"   REPORT KEY"
    30         W !,"   Field Name              Explanation of field name"
    31         W !,"   Patient Name            Name of patient scheduled to be inactivated from their primary care team and position/provider"
    32         W !,"   SSN                     Patient SSN."
    33         W !,"   PC Team                 Patient's assigned Primary Care team in PCMM."
    34         W !,"   Provider                Name of primary care practitioner/provider currently assigned to the patient.  This will be an"
    35         W !,"                           Associate PC Provider if the patient is assigned to an AP, or it will be a Primary Care Provider"
    36         W !,"                           (PCP) if the patient is not assigned to an Associate PC Provider (AP.)"
    37         W !,"   Team Position           The name of the team position to which the current practitioner/provider is assigned."
    38         W !,"   Institution/Division    Institution name, previously called Division, in which patient receives primary care."
    39         W !,"   Sched Date for Inactiva Date patient will be inactivated from PCMM and their Primary Care team and provider/position"
    40         W !,"                           panels. If the patient has a completed outpatient encounter with their current PCP or an"
    41         W !,"                           assigned AP before this date, the patient will not be inactivated.  If the patient's"
    42         W !,"                           inactivation date is extended for 60 days, with the PCMM Extend Patient's Inactivation Date"
    43         W !,"                           option, the patient's inactivation will not occur until the new extended date for inactivation."
    44         W !,"                           Note: There is a patient reassignment option, which allows an inactivated patient to be"
    45         W !,"                           reactivated to their previous Primary Care team and position if they return for care."
    46         W !,"   Next Appt Date          Patient is scheduled for an appointment on this date."
    47         W !,"                           May indicate patient wants to continue their assignment to their Primary Care team and provider."
    48         W !,"   Clinic for next Appt    The clinic in which the patient has their next scheduled appointment."
    49         Q
    50 DIOEND1 ;print Key
    51         N Y,% W @IOF,!,$G(SCDHD) D NOW^%DTC S Y=% W:$X>(IOM-40) ! W ?(IOM-40)
    52         W $P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$E(Y,4,5))_" " W:Y#100 $J(Y#100\1,2)_"," W Y\10000+1700 W:Y#1 "  "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12)
    53         W ?(IOM-15),"PAGE: "_($G(DC)+1)
    54         S Y="",$P(Y,"-",IOM)="" W !,Y,!!
    55         W !,"  REPORT KEY"
    56         W !,"  Field Name              Explanation of field name"
    57         W !,"  Patient Name            Name of patient scheduled to be inactivated from their primary care team and position/provider."
    58         W !,"  SSN                     Patient SSN."
    59         W !,"  Institution             Institution name, previously called Division, in which patient receives primary care."
    60         W !,"  PC Team                 Patient's assigned Primary Care team in PCMM."
    61         W !,"  Provider/               Name of Primary Care practitioner/provider currently assigned to the patient."
    62         W !,"                          This may be an Associate PC Provider (AP,) if the patient is assigned to an AP, or"
    63         W !,"                          it may be a Primary Care Provider (PCP) if the patient is not assigned to an"
    64         W !,"                          Associate PC Provider (AP.)"
    65         W !,"  Team Position           The name of the team position to which the current provider is assigned."
    66         W !,"  Preceptor               Name of Preceptor/Primary Care Provider (PCP) if the patient is assigned to an Associate Provider."
    67         W !,"                          If this field is blank then the patient is assigned to a PCP, who displays in the Provider field."
    68         W !,"  Date Patient            Date patient was inactivated from PCMM and their Primary Care team and provider/position."
    69         W !,"   Inactivated            Note: There is a PCMM patient re-assignment option."
    70         W !,"  Reason Patient          Reason for patient's automated unassignment from their Primary Care team and provider/position."
    71         W !,"   Inactivated            No Appt The patient has been assigned to their current Primary Care Provider (PCP) for"
    72         W !,"                          12 months, and does not have a completed appointment encounter with their PCP or any assigned"
    73         W !,"                          Associated Primary Care Provider (AP) within those 12 months.  Therefore, they are considered"
    74         W !,"                          an inactive patient.  Alternatively, the patient has been assigned to their current PCP for at"
    75         W !,"                          least 12 months, and does not have a completed appointment encounter with their PCP or any"
    76         W !,"                          assigned Associated Primary Care Provider (AP) in the past 24 months. Therefore, they are"
    77         W !,"                          considered an inactive patient."
    78         W !,"                          Death - Patient's death, a date of death was entered in the Registration Package"
    79         Q
    80 DIOEND2 ;print Key
     1SCMCTSK4 ;ALB/JDS - PCMM Inactivation Reports ; 18 Apr 2003  9:36 AM
     2 ;;5.3;Scheduling;**297**;AUG 13, 1993
     3 Q
     4POSCHK ;
     5 N NAME S NAME=$P($G(^SD(403.46,+$P(INFO,U,3),0)),U)
     6 I "RESIDENT (PHYSICIAN)INTERN (PHYSICIAN)"[NAME S $P(DATA,U,3)=1 Q
     7 I "NURSE PRACTITIONERPHYSICIAN ASSISTANT"[NAME S $P(DATA,U,3)=2 Q
     8 I "PHYSICIAN-ATTENDINGPHYSICIAN-PRIMARY CARENURSE PRACTITIONERPHYSICIAN ASSISTANTPHYSICIAN-PSYCHIATRIST"[NAME D  Q
     9 .S $P(DATA,U,3)=3
     10 Q
     11DIOBEG ;
     12 N PG,DC
     13 N Y,% W @IOF,!,$G(SCDHD) D NOW^%DTC S Y=% W:$X>(IOM-40) ! W ?(IOM-40)
     14 W $P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$E(Y,4,5))_" " W:Y#100 $J(Y#100\1,2)_"," W Y\10000+1700 W:Y#1 "  "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12)
     15 W ?(IOM-15),"PAGE: 1"
     16 S Y="",$P(Y,"-",IOM)="" W !,Y,!!
     17 W ?(IOM/2-24),"**** Report Parameters Selected ****",!
     18 S SC="^TMP(""SC"",$J)"
     19 S X=$$PPAR^SCMCTSK8(.SC,.SCT)
     20 S (PG,DC)=1
     21 F  Q:$Y>(IOSL-3)  W !
     22 ;I IOST["C" W !! R SCX:DT I SCX[U S DIOUT=1
     23 Q
     24DIOEND ;print key
     25 N Y,% W @IOF,!,$G(SCDHD) D NOW^%DTC S Y=% W:$X>(IOM-40) ! W ?(IOM-40)
     26 W $P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$E(Y,4,5))_" " W:Y#100 $J(Y#100\1,2)_"," W Y\10000+1700 W:Y#1 "  "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12)
     27 W ?(IOM-15),"PAGE: "_($G(DC)+1)
     28 S Y="",$P(Y,"-",IOM)="" W !,Y,!!
     29 W !,"   REPORT KEY"
     30 W !,"   Field Name              Explanation of field name"
     31 W !,"   Patient Name            Name of patient scheduled to be inactivated from their primary care team and position/provider"
     32 W !,"   SSN                     Patient's last 4 Social Security numbers."
     33 W !,"   PC Team                 Patient's assigned Primary Care team in PCMM."
     34 W !,"   Provider                Name of primary care practitioner/provider currently assigned to the patient.  This will be an"
     35 W !,"                           Associate PC Provider if the patient is assigned to an AP, or it will be a Primary Care Provider"
     36 W !,"                           (PCP) if the patient is not assigned to an Associate PC Provider (AP.)"
     37 W !,"   Team Position           The name of the team position to which the current practitioner/provider is assigned."
     38 W !,"   Institution/Division    Institution name, previously called Division, in which patient receives primary care."
     39 W !,"   Sched Date for Inactiva Date patient will be inactivated from PCMM and their Primary Care team and provider/position"
     40 W !,"                           panels. If the patient has a completed outpatient encounter with their current PCP or an"
     41 W !,"                           assigned AP before this date, the patient will not be inactivated.  If the patient's"
     42 W !,"                           inactivation date is extended for 60 days, with the PCMM Extend Patient's Inactivation Date"
     43 W !,"                           option, the patient's inactivation will not occur until the new extended date for inactivation."
     44 W !,"                           Note: There is a patient reassignment option, which allows an inactivated patient to be"
     45 W !,"                           reactivated to their previous Primary Care team and position if they return for care."
     46 W !,"   Next Appt Date          Patient is scheduled for an appointment on this date."
     47 W !,"                           May indicate patient wants to continue their assignment to their Primary Care team and provider."
     48 W !,"   Clinic for next Appt    The clinic in which the patient has their next scheduled appointment."
     49 Q
     50DIOEND1 ;print Key
     51 N Y,% W @IOF,!,$G(SCDHD) D NOW^%DTC S Y=% W:$X>(IOM-40) ! W ?(IOM-40)
     52 W $P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$E(Y,4,5))_" " W:Y#100 $J(Y#100\1,2)_"," W Y\10000+1700 W:Y#1 "  "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12)
     53 W ?(IOM-15),"PAGE: "_($G(DC)+1)
     54 S Y="",$P(Y,"-",IOM)="" W !,Y,!!
     55 W !,"  REPORT KEY"
     56 W !,"  Field Name              Explanation of field name"
     57 W !,"  Patient Name            Name of patient scheduled to be inactivated from their primary care team and position/provider."
     58 W !,"  SSN                     Patient's last 4 SSN numbers."
     59 W !,"  Institution             Institution name, previously called Division, in which patient receives primary care."
     60 W !,"  PC Team                 Patient's assigned Primary Care team in PCMM."
     61 W !,"  Provider/               Name of Primary Care practitioner/provider currently assigned to the patient."
     62 W !,"                          This may be an Associate PC Provider (AP,) if the patient is assigned to an AP, or"
     63 W !,"                          it may be a Primary Care Provider (PCP) if the patient is not assigned to an"
     64 W !,"                          Associate PC Provider (AP.)"
     65 W !,"  Team Position           The name of the team position to which the current provider is assigned."
     66 W !,"  Preceptor               Name of Preceptor/Primary Care Provider (PCP) if the patient is assigned to an Associate Provider."
     67 W !,"                          If this field is blank then the patient is assigned to a PCP, who displays in the Provider field."
     68 W !,"  Date Patient            Date patient was inactivated from PCMM and their Primary Care team and provider/position."
     69 W !,"   Inactivated            Note: There is a PCMM patient re-assignment option."
     70 W !,"  Reason Patient          Reason for patient's automated unassignment from their Primary Care team and provider/position."
     71 W !,"   Inactivated            No Appt The patient has been assigned to their current Primary Care Provider (PCP) for"
     72 W !,"                          12 months, and does not have a completed appointment encounter with their PCP or any assigned"
     73 W !,"                          Associated Primary Care Provider (AP) within those 12 months.  Therefore, they are considered"
     74 W !,"                          an inactive patient.  Alternatively, the patient has been assigned to their current PCP for at"
     75 W !,"                          least 12 months, and does not have a completed appointment encounter with their PCP or any"
     76 W !,"                          assigned Associated Primary Care Provider (AP) in the past 24 months. Therefore, they are"
     77 W !,"                          considered an inactive patient."
     78 W !,"                          Death - Patient's death, a date of death was entered in the Registration Package"
     79 Q
     80DIOEND2 ;print Key

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCTSK9.m

    r613 r623  
    1 SCMCTSK9        ;;BP/DMR - PCMM ; 18 Apr 2003  9:36 AM
    2         ;;5.3;Scheduling;**297,526**;AUG 13, 1993;Build 8
    3         Q
    4 EXTKEY  ;
    5         N Y,% W @IOF,!,$G(SCDHD) D NOW^%DTC S Y=% W:$X>(IOM-40) ! W ?(IOM-40)
    6         W $P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$E(Y,4,5))_" " W:Y#100 $J(Y#100\1,2)_"," W Y\10000+1700 W:Y#1 "  "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12)
    7         W ?(IOM-15),"PAGE: "_($G(DC)+1)
    8         S Y="",$P(Y,"-",IOM)="" W !,Y,!!
    9         W !,"Column Heading        Explanation of column headings"
    10         W !
    11         W !,"Patient Name          Name of patient scheduled to be inactivated from their primary care team and position/provider."
    12         W !,"SSN                   SSN number."
    13         W !,"Institution           Institution name, previously called Division, in which patient receives primary care."
    14         W !,"PC Team               The patient's assigned Primary Care team in PCMM."
    15         W !,"Provider/             Name of Associate Primary Care Provider (AP) assigned to patient, if there is one."
    16         W !," Team Position        The name of the team position to which the Associate Primary Care Provider (AP) is assigned."
    17         W !,"Current Preceptor/    Name of Primary Care Provider (PCP) assigned to patient.  Every Primary Care patient should"
    18         W !," Team Position        be assigned to one PCP. The name of the team position to which the Primary Care Provider (PCP)"
    19         W !,"                      is assigned."
    20         W !,"Date Scheduled for    Date patient will be inactivated from PCMM and their Primary Care team and provider/position unless"
    21         W !," Inactivation         they have a completed outpatient appointment encounter with their current PCP or AP before this date."
    22         W !,"                      Note: There is a patient reassignment option, which allows an inactivated patient to be reactivated"
    23         W !,"                      to their previous Primary Care team and position if they return for care."
    24         W !,"Reason for Extended   The reason entered for extending the patient's time before inactivation from PC panels."
    25         W !," Inactivation         Entry of this field is in the PCMM GUI, Patient drop down menu, and the Extend Patient's Date for"
    26         W !,"                      Inactivation from PC Panels option."
    27         Q
    28 EXTCHUI ;roll n scroll option to extend a patient
    29         N DA,DIC,DIE,DR,SCTM,SCARRAY,SCHIGH,SCX,V1
    30         S SCTM=0 F  D P1 Q:+SCTM<1
    31         Q
    32 P1      D GCL S DIC="^SCTM(404.51,",DIC(0)="AEQMZ" D ^DIC S SCTM=+Y Q:+SCTM<1
    33         W !,"Searching...",!
    34         D EXTEND(.SCARRAY,SCTM)
    35         I $G(^TMP("SCMCTSK9","OUT",$J,1))="<DATA>" W !,"No Patients to Extend..." D GCL Q
    36         S SCHIGH=$O(^TMP("SCMCTSK9","OUT",$J,9999999),-1)
    37         S SCX=999 F  Q:(SCX="^")!(SCX="")  D P2
    38         Q
    39 P2      W !,"Select From:  ",!!
    40         S V1=0 F  S V1=$O(^TMP("SCMCTSK9","OUT",$J,V1)) Q:'V1  D
    41         . W $J(V1,2)_" ",$P(^TMP("SCMCTSK9","OUT",$J,V1),U,3),!
    42         F  W !,"Select 1-",SCHIGH," " R SCX:DTIME Q:(SCX="^")!(SCX="")!((SCX'>SCHIGH)&(SCX>0))  D
    43         . I $E(SCX,1)="?" W !,"Select 1-",SCHIGH," or '^' to exit" Q
    44         . I (+SCX<1)!(+SCX>SCHIGH) W !,"Select a valid number" Q
    45         I SCX'?1.9N Q
    46         S DIE="^SCPT(404.43,"
    47         S DA=$P(^TMP("SCMCTSK9","OUT",$J,SCX),U)
    48         S DR=".13//DO NOT EXTEND;S Y=.16 I X=4 S Y=.14;.14;.16////"_DUZ
    49         D ^DIE
    50         Q
    51 EXTEND(DATA,SCTEAM)     ;return list of patients to inactivate in next 60 days
    52         ;IEN^POSITION^PATIENT^EXTENDED^REASON
    53         K DATA,SCDATA,SDDATA
    54         N CNT,I,J,K,A,POSA S CNT=1 S SCTEAM=$G(SCTEAM),^TMP("SCMCTSK9","OUT",$J,1)="<DATA>"
    55         D DT^DICRW S X="T-9M" D ^%DT S STDT=Y
    56         S X="T-21M" D ^%DT S TYDT=+Y  ;MAKE THIS 21
    57         S POSA=""
    58         F  S POSA=$O(^SCTM(404.57,"ATMPOS",+SCTEAM,POSA)) Q:POSA=""  D
    59         .F POS=0:0 S POS=$O(^SCTM(404.57,"ATMPOS",+SCTEAM,POSA,POS)) Q:'POS  D POS
    60 EX1     S A="^TMP(""SCMCTSK9"",$J)",CNT=1 F  S A=$Q(@A) Q:A=""!($P(A,",",2)'=$J)  D
    61         .S B=@A
    62         .S ^TMP("SCMCTSK9","OUT",$J,CNT)=(+$P(B,U,3))_U_$TR($P($P(A,"(",4),","),$C(34))_U_$TR($P(B,U,2),$C(34))_U_$P($G(^SCPT(404.43,+$P(B,U,3),0)),U,13)_U_$P($G(^SCPT(404.43,+$P(B,U,3),0)),U,14)
    63         .S CNT=CNT+1
    64         Q
    65 POS     I '$$DATES^SCAPMCU1(404.59,POS) Q   ;Not an active position
    66         I '$P($G(^SCTM(404.57,POS,0)),U,4) Q  ;Not PC
    67         ;get patients for this position
    68         K ^TMP("SC TMP LIST",$J)
    69         S X=$$PTTP^SCAPMC(POS,"",.SCLIST,.SCERR)
    70         S J=0 F  S J=$O(@SCLIST@(J)) Q:'J  S SCDATA=^(J) D
    71         .N J I $P(SCDATA,U,4)>STDT Q
    72         .I '$P($G(^SCPT(404.43,+$P(SCDATA,U,3),0)),U,5) Q
    73         .I '$P($G(^SCPT(404.43,+$P(SCDATA,U,3),0)),U,15) Q
    74         .S DFN=+SCDATA
    75         .D SEEN Q:SEEN
    76         .S ^TMP("SCMCTSK9",$J,$P($G(^SCTM(404.57,POS,0)),U),$P(SCDATA,U,2),+SCDATA)=SCDATA,CNT=CNT+1
    77         K @SCLIST
    78         Q
    79 SEEN    ;was patient seen
    80         S SEEN=0
    81         N SCPRO,I,PRECP,PRO
    82         N X,SCPRDTS,SCPR
    83         ;get list of providers for this position
    84         S PROV=+$$GETPRTP^SCAPMCU2(POS,DT) S SCPRO(+PROV)=""
    85         S SCPRDTS("BEGIN")=TYDT
    86         S SCPRDTS("END")=DT
    87         S X=$$PRTP^SCAPMC(POS,"SCPRDTS","SCPR")
    88         F I=0:0 S I=$O(SCPR(I)) Q:'I  S SCPRO(+SCPR(I))=""
    89         S PRECP=0 I $G(PREC),$G(PREC)'=POS S PRECP=+$$GETPRTP^SCAPMCU2(PREC,DT),SCPRO(+PRECP)=""
    90         F I=TYDT:0 S I=$O(^SCE("ADFN",DFN,I)) Q:'I  D  Q:SEEN
    91         .F J=0:0 S J=$O(^SCE("ADFN",DFN,I,J)) Q:'J  D  Q:SEEN
    92         ..N VISIT S VISIT=+$P($G(^SCE(J,0)),U,5) I $G(^SCE(J,0))<$G(TYDT) Q
    93         ..F PRO=0:0 S PRO=$O(SCPRO(PRO)) Q:'PRO  D  Q:SEEN
    94         ...I $D(^SDD(409.44,"AO",J,$G(PRO))) S SEEN=1 Q  ;GET THE PROVIDERJ
    95         ...N V F V=0:0 S V=$O(^AUPNVPRV("AD",VISIT,V)) Q:'V  I PRO=(+$G(^AUPNVPRV(V,0))) S SEEN=1 Q
    96         Q
    97 GCL     ;clean temp globals
    98         K ^TMP("SCMCTSK9",$J)
    99         K ^TMP("SCMCTSK9","OUT",$J)
    100         Q
     1SCMCTSK9 ;;BP/DMR - PCMM ; 18 Apr 2003  9:36 AM
     2 ;;5.3;Scheduling;**297**;AUG 13, 1993
     3 Q
     4EXTKEY ;
     5 N Y,% W @IOF,!,$G(SCDHD) D NOW^%DTC S Y=% W:$X>(IOM-40) ! W ?(IOM-40)
     6 W $P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$E(Y,4,5))_" " W:Y#100 $J(Y#100\1,2)_"," W Y\10000+1700 W:Y#1 "  "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12)
     7 W ?(IOM-15),"PAGE: "_($G(DC)+1)
     8 S Y="",$P(Y,"-",IOM)="" W !,Y,!!
     9 W !,"Column Heading        Explanation of column headings"
     10 W !
     11 W !,"Patient Name          Name of patient scheduled to be inactivated from their primary care team and position/provider."
     12 W !,"SSN                   Patient's last 4 SSN numbers."
     13 W !,"Institution           Institution name, previously called Division, in which patient receives primary care."
     14 W !,"PC Team               The patient's assigned Primary Care team in PCMM."
     15 W !,"Provider/             Name of Associate Primary Care Provider (AP) assigned to patient, if there is one."
     16 W !," Team Position        The name of the team position to which the Associate Primary Care Provider (AP) is assigned."
     17 W !,"Current Preceptor/    Name of Primary Care Provider (PCP) assigned to patient.  Every Primary Care patient should"
     18 W !," Team Position        be assigned to one PCP. The name of the team position to which the Primary Care Provider (PCP)"
     19 W !,"                      is assigned."
     20 W !,"Date Scheduled for    Date patient will be inactivated from PCMM and their Primary Care team and provider/position unless"
     21 W !," Inactivation         they have a completed outpatient appointment encounter with their current PCP or AP before this date."
     22 W !,"                      Note: There is a patient reassignment option, which allows an inactivated patient to be reactivated"
     23 W !,"                      to their previous Primary Care team and position if they return for care."
     24 W !,"Reason for Extended   The reason entered for extending the patient's time before inactivation from PC panels."
     25 W !," Inactivation         Entry of this field is in the PCMM GUI, Patient drop down menu, and the Extend Patient's Date for"
     26 W !,"                      Inactivation from PC Panels option."
     27 Q
     28EXTCHUI ;roll n scroll option to extend a patient
     29 N DA,DIC,DIE,DR,SCTM,SCARRAY,SCHIGH,SCX,V1
     30 S SCTM=0 F  D P1 Q:+SCTM<1
     31 Q
     32P1 D GCL S DIC="^SCTM(404.51,",DIC(0)="AEQMZ" D ^DIC S SCTM=+Y Q:+SCTM<1
     33 W !,"Searching...",!
     34 D EXTEND(.SCARRAY,SCTM)
     35 I $G(^TMP("SCMCTSK9","OUT",$J,1))="<DATA>" W !,"No Patients to Extend..." D GCL Q
     36 S SCHIGH=$O(^TMP("SCMCTSK9","OUT",$J,9999999),-1)
     37 S SCX=999 F  Q:(SCX="^")!(SCX="")  D P2
     38 Q
     39P2 W !,"Select From:  ",!!
     40 S V1=0 F  S V1=$O(^TMP("SCMCTSK9","OUT",$J,V1)) Q:'V1  D
     41 . W $J(V1,2)_" ",$P(^TMP("SCMCTSK9","OUT",$J,V1),U,3),!
     42 F  W !,"Select 1-",SCHIGH," " R SCX:DTIME Q:(SCX="^")!(SCX="")!((SCX'>SCHIGH)&(SCX>0))  D
     43 . I $E(SCX,1)="?" W !,"Select 1-",SCHIGH," or '^' to exit" Q
     44 . I (+SCX<1)!(+SCX>SCHIGH) W !,"Select a valid number" Q
     45 I SCX'?1.9N Q
     46 S DIE="^SCPT(404.43,"
     47 S DA=$P(^TMP("SCMCTSK9","OUT",$J,SCX),U)
     48 S DR=".13//DO NOT EXTEND;S Y=.16 I X=4 S Y=.14;.14;.16////"_DUZ
     49 D ^DIE
     50 Q
     51EXTEND(DATA,SCTEAM) ;return list of patients to inactivate in next 60 days
     52 ;IEN^POSITION^PATIENT^EXTENDED^REASON
     53 K DATA,SCDATA,SDDATA
     54 N CNT,I,J,K,A,POSA S CNT=1 S SCTEAM=$G(SCTEAM),^TMP("SCMCTSK9","OUT",$J,1)="<DATA>"
     55 D DT^DICRW S X="T-9M" D ^%DT S STDT=Y
     56 S X="T-21M" D ^%DT S TYDT=+Y  ;MAKE THIS 21
     57 S POSA=""
     58 F  S POSA=$O(^SCTM(404.57,"ATMPOS",+SCTEAM,POSA)) Q:POSA=""  D
     59 .F POS=0:0 S POS=$O(^SCTM(404.57,"ATMPOS",+SCTEAM,POSA,POS)) Q:'POS  D POS
     60EX1 S A="^TMP(""SCMCTSK9"",$J)",CNT=1 F  S A=$Q(@A) Q:A=""!($P(A,",",2)'=$J)  D
     61 .S B=@A
     62 .S ^TMP("SCMCTSK9","OUT",$J,CNT)=(+$P(B,U,3))_U_$TR($P($P(A,"(",4),","),$C(34))_U_$TR($P(B,U,2),$C(34))_U_$P($G(^SCPT(404.43,+$P(B,U,3),0)),U,13)_U_$P($G(^SCPT(404.43,+$P(B,U,3),0)),U,14)
     63 .S CNT=CNT+1
     64 Q
     65POS I '$$DATES^SCAPMCU1(404.59,POS) Q   ;Not an active position
     66 I '$P($G(^SCTM(404.57,POS,0)),U,4) Q  ;Not PC
     67 ;get patients for this position
     68 K ^TMP("SC TMP LIST",$J)
     69 S X=$$PTTP^SCAPMC(POS,"",.SCLIST,.SCERR)
     70 S J=0 F  S J=$O(@SCLIST@(J)) Q:'J  S SCDATA=^(J) D
     71 .N J I $P(SCDATA,U,4)>STDT Q
     72 .I '$P($G(^SCPT(404.43,+$P(SCDATA,U,3),0)),U,5) Q
     73 .I '$P($G(^SCPT(404.43,+$P(SCDATA,U,3),0)),U,15) Q
     74 .S DFN=+SCDATA
     75 .D SEEN Q:SEEN
     76 .S ^TMP("SCMCTSK9",$J,$P($G(^SCTM(404.57,POS,0)),U),$P(SCDATA,U,2),+SCDATA)=SCDATA,CNT=CNT+1
     77 K @SCLIST
     78 Q
     79SEEN ;was patient seen
     80 S SEEN=0
     81 N SCPRO,I,PRECP,PRO
     82 N X,SCPRDTS,SCPR
     83 ;get list of providers for this position
     84 S PROV=+$$GETPRTP^SCAPMCU2(POS,DT) S SCPRO(+PROV)=""
     85 S SCPRDTS("BEGIN")=TYDT
     86 S SCPRDTS("END")=DT
     87 S X=$$PRTP^SCAPMC(POS,"SCPRDTS","SCPR")
     88 F I=0:0 S I=$O(SCPR(I)) Q:'I  S SCPRO(+SCPR(I))=""
     89 S PRECP=0 I $G(PREC),$G(PREC)'=POS S PRECP=+$$GETPRTP^SCAPMCU2(PREC,DT),SCPRO(+PRECP)=""
     90 F I=TYDT:0 S I=$O(^SCE("ADFN",DFN,I)) Q:'I  D  Q:SEEN
     91 .F J=0:0 S J=$O(^SCE("ADFN",DFN,I,J)) Q:'J  D  Q:SEEN
     92 ..N VISIT S VISIT=+$P($G(^SCE(J,0)),U,5) I $G(^SCE(J,0))<$G(TYDT) Q
     93 ..F PRO=0:0 S PRO=$O(SCPRO(PRO)) Q:'PRO  D  Q:SEEN
     94 ...I $D(^SDD(409.44,"AO",J,$G(PRO))) S SEEN=1 Q  ;GET THE PROVIDERJ
     95 ...N V F V=0:0 S V=$O(^AUPNVPRV("AD",VISIT,V)) Q:'V  I PRO=(+$G(^AUPNVPRV(V,0))) S SEEN=1 Q
     96 Q
     97GCL ;clean temp globals
     98 K ^TMP("SCMCTSK9",$J)
     99 K ^TMP("SCMCTSK9","OUT",$J)
     100 Q

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMSVUT2.m

    r613 r623  
    1 SCMSVUT2        ;ALB/JLU;Utility routine for AMBCARE;06/28/99
    2         ;;5.3;Scheduling;**66,180,254,293,325,466,521**;AUG 13,1993;Build 1
    3         ;06/28/99 ACS Added CPT modifier validation
    4         ;
    5 COUNT(VALER)    ;counts the number of errored encounters found.
    6         ;INPUT VALER - The array containing the errors.
    7         ;OUTPUT the number of errors
    8         ;
    9         N VAR,CNT
    10         S VAR="",CNT=0
    11         F  S VAR=$O(@VALER@(VAR)) Q:VAR']""  S CNT=CNT+1
    12         Q CNT
    13         ;
    14 IPERR(VALER)    ;counts the number of inpatient errored encounters found.
    15         ;INPUT VALER - The array containing the errors.
    16         ;OUTPUT the number of errors
    17         ;
    18         N VAR,CNT
    19         S VAR="",CNT=0
    20         F  S VAR=$O(@VALER@(VAR)) Q:VAR']""  D
    21         .I $$INPATENC^SCDXUTL(VAR) S CNT=CNT+1
    22         Q CNT
    23         ;
    24 FILEVERR(PTR,VALERR)    ;files the errors found for an encounter
    25         ;INPUT  PTR - The pointer to the entry in the transmission file 409.73
    26         ;      VALERR - The array holding the errors for the encounter.
    27         ;OUTPUT  0 - did not file
    28         ;        1 - did file
    29         N SEG,FILE
    30         I '$D(VALERR) Q 0
    31         S SEG="",FILE=-1
    32         F  S SEG=$O(@VALERR@(SEG)) Q:SEG']""  D FILE(VALERR,SEG,PTR,.FILE)
    33         Q $S(FILE=1:1,1:0)
    34         ;
    35 FILE(VALERR,SEG,PTR,FILE)       ;
    36         N NBR
    37         S NBR=0
    38         F  S NBR=$O(@VALERR@(SEG,NBR)) Q:'NBR  DO
    39         .N CODPTR,CODE
    40         .S CODE=$G(@VALERR@(SEG,NBR))
    41         .I CODE']"" Q
    42         .S CODPTR=$O(^SD(409.76,"B",CODE,""))
    43         .I 'CODPTR Q
    44         .I $D(^SD(409.75,"AER",PTR,CODPTR)) S FILE=1 Q
    45         .S FILE=$$CRTERR^SCDXFU02(PTR,CODE)
    46         .Q
    47         Q
    48         ;
    49 VALWL(CLIN)     ;WORKLOAD VALIDATION AT CHECK OUT
    50         ;INPUT CLIN - IEN OF CLINIC
    51         ;OUTPUT 0 - DO NOT VALIDATE WORKLOAD
    52         ;       1 - VALIDATE CLINIC WORKLOAD
    53         N A1
    54         I '$D(CLIN) S CLIN=0
    55         S A1=$P($G(^SC(+CLIN,0)),U,30)
    56         Q $S(A1=1:1,1:0)
    57         ;
    58 VALIDATE(XMITPTR)       ;validates data that has a entry in the transmit file.
    59         ;
    60         ;INPUT    XMITPTR - This is the point to an entry in file 409.73.
    61         ;
    62         ;OUTPUT    -1 - the was a problem with the inputs
    63         ;           0 - no errors were found
    64         ;           1 - errors were found
    65         ;
    66         N VALERR,ERR,HL,HLEID,DFN
    67         S ANS=-1
    68         S XMITPTR=+$G(XMITPTR)
    69         I $G(^SD(409.73,XMITPTR,0))']"" G VALQ
    70         D PATDFN^SCDXUTL2(XMITPTR)
    71         ;
    72         S HL7XMIT="^TMP(""HLS"","_$J_")",VALERR="^TMP(""SCDXVALID"","_$J_","_XMITPTR_")"
    73         ;Initialze HL7 variables
    74         S HLEID=+$O(^ORD(101,"B","SCDX AMBCARE SEND SERVER FOR ADT-Z00",0))
    75         I ('HLEID) G VALQ
    76         D INIT^HLFNC2(HLEID,.HL)
    77         I ($O(HL(""))="") G VALQ
    78         ;
    79         S ERR=$$BUILDHL7^SCDXMSG0(XMITPTR,.HL,1,HL7XMIT,1,VALERR)
    80         ;
    81         I ERR<0,$O(@VALERR@(0))']"" D VALIDATE^SCMSVUT0("INTERNAL","","V900",VALERR,0)
    82         S ANS=0
    83         D DELAERR^SCDXFU02(XMITPTR,0)
    84         D DEMUPDT(DFN,VALERR,"DEMO")
    85         I $O(@VALERR@(0))]"" DO
    86         .N FILE
    87         .S ANS=1
    88         .S FILE=$$FILEVERR(XMITPTR,VALERR)
    89         .Q
    90         ;
    91         K @VALERR,@HL7XMIT
    92         ;
    93 VALQ    Q ANS
    94         ;
    95 DEMUPDT(DFN,VALERR,TYP) ;
    96         ;This entry point updates all the other encoutners for this patient
    97         ;that HAVE errors with a new set or demographic errors or deletes all
    98         ;the demographic errors if none were found.
    99         ;INPUT DFN - The patient's DFN
    100         ;   VALERR - errors to log
    101         ;      TYP - The type of errors to delete and log.
    102         ;            Right now demographic errors are the only kind "DEMO"
    103         ;
    104         S DFN=$G(DFN),TYP=$G(TYP),VALERR=$G(VALERR)
    105         I DFN=""!(TYP="")!(VALERR="") Q
    106         N PTRS,RNG,LP,PTR
    107         S RNG=$P($T(@(TYP)),";;",2),PTRS=""
    108         D CLEAN(DFN,RNG,.PTRS)
    109         I '$D(@VALERR@("PID")) Q
    110         I PTRS']"" Q
    111         F LP=1:1 S PTR=$P(PTRS,U,LP) Q:PTR']""  DO
    112         .I '$D(^SD(409.73,PTR,0)) Q
    113         .N FILE
    114         .D FILE(VALERR,"PID",PTR,.FILE)
    115         .Q
    116         Q
    117         ;
    118 CLEAN(DFN,RNG,PTRS)     ;This subroutine cleans out all errors for a pateint
    119         ;and returns a string of which entries in 409.73 were cleaned of errors
    120         ;
    121         N LP,COD,LP2,IEN
    122         F LP=1:1 S COD=$P(RNG,U,LP) Q:COD']""  I $D(^SD(409.75,"ACOD",DFN,COD)) S IEN="" F LP2=1:1 S IEN=$O(^SD(409.75,"ACOD",DFN,COD,IEN)) Q:IEN']""  DO
    123         .N VAR,RES
    124         .S VAR=$P($G(^SD(409.75,IEN,0)),U,1)_"^"
    125         .I $P(VAR,U,1)="" S PTR="" Q
    126         .S RES=$$DELERR^SCDXFU02(IEN)
    127         .I PTRS[VAR Q
    128         .S PTRS=PTRS_VAR
    129         .Q
    130         Q
    131         ;
    132 MODCODE(DATA,ENCDT)     ;
    133         ;
    134         ;---------------------------------------------------------------
    135         ;    VALIDATE MODIFIER AND CPT+MODIFIER COMBINATION
    136         ;
    137         ; INPUT: DATA - The procedure and modifier code to be checked
    138         ;               format: CPT~modifier
    139         ;       ENCDT - The date of the encounter
    140         ;
    141         ;OUTPUT:    1 - valid modifier and CPT+modifier combination
    142         ;           0 - invalid modifier or CPT+modifier combination
    143         ;
    144         ;**NOTE**   This call makes the assumption that leading zeros are
    145         ;           intact in the input.
    146         ;---------------------------------------------------------------
    147         ;
    148         ;- validate modifier only
    149         N DATAMOD
    150         S DATAMOD=$P(DATA,"~",2)
    151         I '$D(DATAMOD) Q 0
    152         I $$MOD^ICPTMOD(DATAMOD,"E",ENCDT,1)'>0 Q 0
    153         ;
    154         ;- validate CPT+modifier pair
    155         N DATAPROC
    156         S DATAPROC=$P(DATA,"~",1)
    157         I '$D(DATAPROC) Q 0
    158         I $$MODP^ICPTMOD(DATAPROC,DATAMOD,"E",ENCDT,1)'>0 Q 0
    159         Q 1
    160         ;
    161 MODMETH(DATA)   ;
    162         ;
    163         ;---------------------------------------------------------------
    164         ;    VALIDATE MODIFIER CODING METHOD
    165         ;
    166         ; INPUT: DATA - The modifier coding method to be checked
    167         ;
    168         ;OUTPUT:    1 - valid modifier coding method
    169         ;           0 - invalid modifier coding method
    170         ;
    171         ; Valid modifier coding methods: C and H
    172         ;---------------------------------------------------------------
    173         ;
    174         I '$D(DATA) Q 0
    175         S DATA=","_DATA_","
    176         I ",C,H,"'[DATA Q 0
    177         Q 1
    178         ;
    179 ETHNIC(DATA)       ;
    180         ;INPUT  DATA - the ethnicity code to be validated (NNNN-C-XXX)
    181         ;
    182         N VAL,MTHD
    183         I '$D(DATA) Q 0
    184         I DATA="" Q 1
    185         S VAL=$P(DATA,"-",1,2)
    186         S MTHD=$P(DATA,"-",3)
    187         I VAL'?4N1"-"1N Q 0
    188         I ",SLF,UNK,PRX,OBS,"'[MTHD Q 0
    189         Q 1
    190 CONFDT(DATA,SUB)           ;CONFIDENTIAL ADDRESS START/STOP DATE
    191         N X,Y,%DT,DTOUT,STDT,ENDT
    192         I '$D(DATA) Q 0
    193         S STDT=$P(DATA,SUB,1)
    194         S ENDT=$P(DATA,SUB,2)
    195         I STDT="" Q 0
    196         S STDT=$$FMDATE^HLFNC(STDT)
    197         S X=STDT,%DT="X" D ^%DT I Y=-1 Q 0  ;SD/521 added %DT
    198         I ENDT="" Q 1
    199         S ENDT=$$FMDATE^HLFNC(ENDT)
    200         S X=ENDT,%DT="X" D ^%DT I Y=-1 Q 0  ;SD/521 added %DT
    201         I $$FMDIFF^XLFDT(ENDT,STDT,1)<0 Q 0
    202         Q 1
    203         ;
    204 CONFCAT(DATA)               ;CONFIDENTIAL ADDRESS CATEGORY TYPE
    205         I '$D(DATA) Q 0
    206         I DATA="" Q 0
    207         N VAL,GOOD
    208         S GOOD=0
    209         F VAL="VACAA","VACAC","VACAE","VACAM","VACAO" I DATA=VAL S GOOD=1 Q
    210         Q GOOD
    211         ;
    212 CVEDT(DATA)     ;Combat vet end date (ZEL.38)
    213         ;Input  : DATA - CombatVetIndicator ^ CombatVetEndDate
    214         ;Output : 1 = Good / 0 = Bad
    215         ;
    216         N CVI,CVEDT
    217         S DATA=$G(DATA)
    218         S CVI=$P(DATA,"^",1)
    219         S CVEDT=$P(DATA,"^",2)
    220         I 'CVI Q $S(CVEDT="":1,1:0)
    221         Q CVEDT?8N
    222         ;
    223 CLCV(DATA,SDOE) ;Cross check for combat vet classification question
    224         ;Input  : DATA - Answer to classification question
    225         ;         SDOE - Pointer to encounter (file # 409.68)
    226         ;Output : 1 = Good / 0 = Bad
    227         ;
    228         S DATA=$G(DATA)
    229         Q:(DATA'=1) 1
    230         N VET,SDDT,SDOE0
    231         S SDOE=$G(SDOE) Q:'SDOE 0
    232         S SDOE0=$G(^SCE(SDOE,0))
    233         S SDDT=+SDOE0 Q:'SDDT 0
    234         S DFN=+$P(SDOE0,"^",2) Q:'DFN 0
    235         S VET=$P($$EL^SDCO22(DFN,SDOE),"^",5)
    236         I VET'="Y" Q 0
    237         S VET=+$$CVEDT^DGCV(DFN,SDDT)
    238         Q $S(VET=1:1,1:0)
    239         ;
    240 DEMO    ;;2000^2030^2050^2100^2150^2200^2210^2220^2230^2240^2250^2300^2330^2360
     1SCMSVUT2 ;ALB/JLU;Utility routine for AMBCARE;06/28/99
     2 ;;5.3;Scheduling;**66,180,254,293,325,466**;AUG 13,1993;Build 2
     3 ;06/28/99 ACS Added CPT modifier validation
     4 ;
     5COUNT(VALER) ;counts the number of errored encounters found.
     6 ;INPUT VALER - The array containing the errors.
     7 ;OUTPUT the number of errors
     8 ;
     9 N VAR,CNT
     10 S VAR="",CNT=0
     11 F  S VAR=$O(@VALER@(VAR)) Q:VAR']""  S CNT=CNT+1
     12 Q CNT
     13 ;
     14IPERR(VALER) ;counts the number of inpatient errored encounters found.
     15 ;INPUT VALER - The array containing the errors.
     16 ;OUTPUT the number of errors
     17 ;
     18 N VAR,CNT
     19 S VAR="",CNT=0
     20 F  S VAR=$O(@VALER@(VAR)) Q:VAR']""  D
     21 .I $$INPATENC^SCDXUTL(VAR) S CNT=CNT+1
     22 Q CNT
     23 ;
     24FILEVERR(PTR,VALERR) ;files the errors found for an encounter
     25 ;INPUT  PTR - The pointer to the entry in the transmission file 409.73
     26 ;      VALERR - The array holding the errors for the encounter.
     27 ;OUTPUT  0 - did not file
     28 ;        1 - did file
     29 N SEG,FILE
     30 I '$D(VALERR) Q 0
     31 S SEG="",FILE=-1
     32 F  S SEG=$O(@VALERR@(SEG)) Q:SEG']""  D FILE(VALERR,SEG,PTR,.FILE)
     33 Q $S(FILE=1:1,1:0)
     34 ;
     35FILE(VALERR,SEG,PTR,FILE) ;
     36 N NBR
     37 S NBR=0
     38 F  S NBR=$O(@VALERR@(SEG,NBR)) Q:'NBR  DO
     39 .N CODPTR,CODE
     40 .S CODE=$G(@VALERR@(SEG,NBR))
     41 .I CODE']"" Q
     42 .S CODPTR=$O(^SD(409.76,"B",CODE,""))
     43 .I 'CODPTR Q
     44 .I $D(^SD(409.75,"AER",PTR,CODPTR)) S FILE=1 Q
     45 .S FILE=$$CRTERR^SCDXFU02(PTR,CODE)
     46 .Q
     47 Q
     48 ;
     49VALWL(CLIN) ;WORKLOAD VALIDATION AT CHECK OUT
     50 ;INPUT CLIN - IEN OF CLINIC
     51 ;OUTPUT 0 - DO NOT VALIDATE WORKLOAD
     52 ;       1 - VALIDATE CLINIC WORKLOAD
     53 N A1
     54 I '$D(CLIN) S CLIN=0
     55 S A1=$P($G(^SC(+CLIN,0)),U,30)
     56 Q $S(A1=1:1,1:0)
     57 ;
     58VALIDATE(XMITPTR) ;validates data that has a entry in the transmit file.
     59 ;
     60 ;INPUT    XMITPTR - This is the point to an entry in file 409.73.
     61 ;
     62 ;OUTPUT    -1 - the was a problem with the inputs
     63 ;           0 - no errors were found
     64 ;           1 - errors were found
     65 ;
     66 N VALERR,ERR,HL,HLEID,DFN
     67 S ANS=-1
     68 S XMITPTR=+$G(XMITPTR)
     69 I $G(^SD(409.73,XMITPTR,0))']"" G VALQ
     70 D PATDFN^SCDXUTL2(XMITPTR)
     71 ;
     72 S HL7XMIT="^TMP(""HLS"","_$J_")",VALERR="^TMP(""SCDXVALID"","_$J_","_XMITPTR_")"
     73 ;Initialze HL7 variables
     74 S HLEID=+$O(^ORD(101,"B","SCDX AMBCARE SEND SERVER FOR ADT-Z00",0))
     75 I ('HLEID) G VALQ
     76 D INIT^HLFNC2(HLEID,.HL)
     77 I ($O(HL(""))="") G VALQ
     78 ;
     79 S ERR=$$BUILDHL7^SCDXMSG0(XMITPTR,.HL,1,HL7XMIT,1,VALERR)
     80 ;
     81 I ERR<0,$O(@VALERR@(0))']"" D VALIDATE^SCMSVUT0("INTERNAL","","V900",VALERR,0)
     82 S ANS=0
     83 D DELAERR^SCDXFU02(XMITPTR,0)
     84 D DEMUPDT(DFN,VALERR,"DEMO")
     85 I $O(@VALERR@(0))]"" DO
     86 .N FILE
     87 .S ANS=1
     88 .S FILE=$$FILEVERR(XMITPTR,VALERR)
     89 .Q
     90 ;
     91 K @VALERR,@HL7XMIT
     92 ;
     93VALQ Q ANS
     94 ;
     95DEMUPDT(DFN,VALERR,TYP) ;
     96 ;This entry point updates all the other encoutners for this patient
     97 ;that HAVE errors with a new set or demographic errors or deletes all
     98 ;the demographic errors if none were found.
     99 ;INPUT DFN - The patient's DFN
     100 ;   VALERR - errors to log
     101 ;      TYP - The type of errors to delete and log.
     102 ;            Right now demographic errors are the only kind "DEMO"
     103 ;
     104 S DFN=$G(DFN),TYP=$G(TYP),VALERR=$G(VALERR)
     105 I DFN=""!(TYP="")!(VALERR="") Q
     106 N PTRS,RNG,LP,PTR
     107 S RNG=$P($T(@(TYP)),";;",2),PTRS=""
     108 D CLEAN(DFN,RNG,.PTRS)
     109 I '$D(@VALERR@("PID")) Q
     110 I PTRS']"" Q
     111 F LP=1:1 S PTR=$P(PTRS,U,LP) Q:PTR']""  DO
     112 .I '$D(^SD(409.73,PTR,0)) Q
     113 .N FILE
     114 .D FILE(VALERR,"PID",PTR,.FILE)
     115 .Q
     116 Q
     117 ;
     118CLEAN(DFN,RNG,PTRS) ;This subroutine cleans out all errors for a pateint
     119 ;and returns a string of which entries in 409.73 were cleaned of errors
     120 ;
     121 N LP,COD,LP2,IEN
     122 F LP=1:1 S COD=$P(RNG,U,LP) Q:COD']""  I $D(^SD(409.75,"ACOD",DFN,COD)) S IEN="" F LP2=1:1 S IEN=$O(^SD(409.75,"ACOD",DFN,COD,IEN)) Q:IEN']""  DO
     123 .N VAR,RES
     124 .S VAR=$P($G(^SD(409.75,IEN,0)),U,1)_"^"
     125 .I $P(VAR,U,1)="" S PTR="" Q
     126 .S RES=$$DELERR^SCDXFU02(IEN)
     127 .I PTRS[VAR Q
     128 .S PTRS=PTRS_VAR
     129 .Q
     130 Q
     131 ;
     132MODCODE(DATA,ENCDT) ;
     133 ;
     134 ;---------------------------------------------------------------
     135 ;    VALIDATE MODIFIER AND CPT+MODIFIER COMBINATION
     136 ;
     137 ; INPUT: DATA - The procedure and modifier code to be checked
     138 ;               format: CPT~modifier
     139 ;       ENCDT - The date of the encounter
     140 ;
     141 ;OUTPUT:    1 - valid modifier and CPT+modifier combination
     142 ;           0 - invalid modifier or CPT+modifier combination
     143 ;
     144 ;**NOTE**   This call makes the assumption that leading zeros are
     145 ;           intact in the input.
     146 ;---------------------------------------------------------------
     147 ;
     148 ;- validate modifier only
     149 N DATAMOD
     150 S DATAMOD=$P(DATA,"~",2)
     151 I '$D(DATAMOD) Q 0
     152 I $$MOD^ICPTMOD(DATAMOD,"E",ENCDT,1)'>0 Q 0
     153 ;
     154 ;- validate CPT+modifier pair
     155 N DATAPROC
     156 S DATAPROC=$P(DATA,"~",1)
     157 I '$D(DATAPROC) Q 0
     158 I $$MODP^ICPTMOD(DATAPROC,DATAMOD,"E",ENCDT,1)'>0 Q 0
     159 Q 1
     160 ;
     161MODMETH(DATA) ;
     162 ;
     163 ;---------------------------------------------------------------
     164 ;    VALIDATE MODIFIER CODING METHOD
     165 ;
     166 ; INPUT: DATA - The modifier coding method to be checked
     167 ;
     168 ;OUTPUT:    1 - valid modifier coding method
     169 ;           0 - invalid modifier coding method
     170 ;
     171 ; Valid modifier coding methods: C and H
     172 ;---------------------------------------------------------------
     173 ;
     174 I '$D(DATA) Q 0
     175 S DATA=","_DATA_","
     176 I ",C,H,"'[DATA Q 0
     177 Q 1
     178 ;
     179ETHNIC(DATA)    ;
     180 ;INPUT  DATA - the ethnicity code to be validated (NNNN-C-XXX)
     181 ;
     182 N VAL,MTHD
     183 I '$D(DATA) Q 0
     184 I DATA="" Q 1
     185 S VAL=$P(DATA,"-",1,2)
     186 S MTHD=$P(DATA,"-",3)
     187 I VAL'?4N1"-"1N Q 0
     188 I ",SLF,UNK,PRX,OBS,"'[MTHD Q 0
     189 Q 1
     190CONFDT(DATA,SUB)    ;CONFIDENTIAL ADDRESS START/STOP DATE
     191 N X,Y,%DT,DTOUT,STDT,ENDT
     192 I '$D(DATA) Q 0
     193 S STDT=$P(DATA,SUB,1)
     194 S ENDT=$P(DATA,SUB,2)
     195 I STDT="" Q 0
     196 S STDT=$$FMDATE^HLFNC(STDT)
     197 S X=STDT D ^%DT I Y=-1 Q 0
     198 I ENDT="" Q 1
     199 S ENDT=$$FMDATE^HLFNC(ENDT)
     200 S X=ENDT D ^%DT I Y=-1 Q 0
     201 I $$FMDIFF^XLFDT(ENDT,STDT,1)<0 Q 0
     202 Q 1
     203 ;
     204CONFCAT(DATA)             ;CONFIDENTIAL ADDRESS CATEGORY TYPE
     205 I '$D(DATA) Q 0
     206 I DATA="" Q 0
     207 N VAL,GOOD
     208 S GOOD=0
     209 F VAL="VACAA","VACAC","VACAE","VACAM","VACAO" I DATA=VAL S GOOD=1 Q
     210 Q GOOD
     211 ;
     212CVEDT(DATA) ;Combat vet end date (ZEL.38)
     213 ;Input  : DATA - CombatVetIndicator ^ CombatVetEndDate
     214 ;Output : 1 = Good / 0 = Bad
     215 ;
     216 N CVI,CVEDT
     217 S DATA=$G(DATA)
     218 S CVI=$P(DATA,"^",1)
     219 S CVEDT=$P(DATA,"^",2)
     220 I 'CVI Q $S(CVEDT="":1,1:0)
     221 Q CVEDT?8N
     222 ;
     223CLCV(DATA,SDOE) ;Cross check for combat vet classification question
     224 ;Input  : DATA - Answer to classification question
     225 ;         SDOE - Pointer to encounter (file # 409.68)
     226 ;Output : 1 = Good / 0 = Bad
     227 ;
     228 S DATA=$G(DATA)
     229 Q:(DATA'=1) 1
     230 N VET,SDDT,SDOE0
     231 S SDOE=$G(SDOE) Q:'SDOE 0
     232 S SDOE0=$G(^SCE(SDOE,0))
     233 S SDDT=+SDOE0 Q:'SDDT 0
     234 S DFN=+$P(SDOE0,"^",2) Q:'DFN 0
     235 S VET=$P($$EL^SDCO22(DFN,SDOE),"^",5)
     236 I VET'="Y" Q 0
     237 S VET=+$$CVEDT^DGCV(DFN,SDDT)
     238 Q $S(VET=1:1,1:0)
     239 ;
     240DEMO ;;2000^2030^2050^2100^2150^2200^2210^2220^2230^2240^2250^2300^2330^2360

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPBK11.m

    r613 r623  
    1 SCRPBK11        ;MJK/ALB - RPC Broker Utilities ; 27 FEB 96
    2         ;;5.3;Scheduling;**41,520**;AUG 13, 1993;Build 26
    3         ;
    4 GETSEL(SCDATA,SCTYPE,SCIEN)     ;
    5         ; -- get SELECTION entity data for details form
    6         ;
    7         ;  input:  SCTYPE       := type of autolink (DIVISIOND, TEAM, ectc.)
    8         ;          SCIEN        := ien of entity
    9         ; output:  SCDATA(1..n) := info about entity
    10         ;
    11         ; -- SEE BOTTOM OF SCRPBK FOR VARIABLE DEFINITIONS
    12         ;
    13         ; Related RPC: SCRP FILE ENTRY GETSELECTION
    14         ;                   
    15         N SC0,SCI,SCINC
    16         S SCINC=0,SCID=+SCIEN
    17         ;
    18         IF SCTYPE="DIVISION" D DIV G GETSELQ
    19         ;
    20         IF SCTYPE="TEAM" D TEAM G GETSELQ
    21         ;
    22         IF SCTYPE="PRACTITIONER" D PRAC G GETSELQ
    23         ;
    24         IF SCTYPE="ROLE" D ROLE G GETSELQ
    25         ;
    26         IF SCTYPE="CLINIC" D CLIN G GETSELQ
    27         ;
    28         IF SCTYPE="USERCLASS" D USER G GETSELQ
    29         ;
    30 GETSELQ Q
    31         ;
    32 SET(X,INC,SCDATA)       ; -- set value in return array
    33         S INC=$G(INC)+1,SCDATA(INC)=X
    34         Q
    35         ;
    36 DIV     ; -- get division details
    37         D SET("Teams in  Division:",.SCINC,.SCDATA)
    38         D SET("------------------",.SCINC,.SCDATA)
    39         S SCI=0 F  S SCI=$O(^SCTM(404.51,"AINST",SCID,SCI)) Q:'SCI  D
    40         . D SET($P($G(^SCTM(404.51,SCI,0)),U),.SCINC,.SCDATA)
    41         Q
    42         ;
    43 TEAM    ; -- get team description
    44         N SC,SCFLE,SCIEN,SCDEF
    45         S SCFLE=404.51,SCIEN=SCID_",",SCDEF="<none specified>"
    46         D GETS^DIQ(SCFLE,SCID_",",50,"","SC")
    47         D SET("Team Description:",.SCINC,.SCDATA)
    48         D SET("-----------------",.SCINC,.SCDATA)
    49         IF $O(SC(SCFLE,SCIEN,50,0)) D
    50         . S SCI=0 F  S SCI=$O(SC(SCFLE,SCIEN,50,SCI)) Q:'SCI  S X=SC(SCFLE,SCIEN,50,SCI) D
    51         . . D SET(X,.SCINC,.SCDATA)
    52         ELSE  D
    53         . D SET(SCDEF,.SCINC,.SCDATA)
    54         Q
    55         ;
    56 PRAC    ; -- get practitioner details
    57         N SC,SCFLE,SCIEN,SCDEF
    58         S SCFLE=200,SCIEN=SCID_",",SCDEF="<none specified>"
    59         D GETS^DIQ(SCFLE,SCID_",","1;8;28","","SC")
    60         D SET(" Initials: "_$S($G(SC(SCFLE,SCIEN,1))]"":SC(SCFLE,SCIEN,1),1:SCDEF),.SCINC,.SCDATA)
    61         D SET("Mail Code: "_$S($G(SC(SCFLE,SCIEN,28))]"":SC(SCFLE,SCIEN,28),1:SCDEF),.SCINC,.SCDATA)
    62         D SET("    Title: "_$S($G(SC(SCFLE,SCIEN,8))]"":SC(SCFLE,SCIEN,8),1:SCDEF),.SCINC,.SCDATA)
    63         Q
    64         ;
    65 ROLE    ; -- get standard role description
    66         N SC,SCFLE,SCIEN,SCDEF
    67         S SCFLE=403.46,SCIEN=SCID_",",SCDEF="<none specified>"
    68         D GETS^DIQ(SCFLE,SCID_",",1,"","SC")
    69         D SET("Role Description:",.SCINC,.SCDATA)
    70         D SET("-----------------",.SCINC,.SCDATA)
    71         IF $O(SC(SCFLE,SCIEN,1,0)) D
    72         . S SCI=0 F  S SCI=$O(SC(SCFLE,SCIEN,1,SCI)) Q:'SCI  S X=SC(SCFLE,SCIEN,1,SCI) D
    73         . . D SET(X,.SCINC,.SCDATA)
    74         ELSE  D
    75         . D SET(SCDEF,.SCINC,.SCDATA)
    76         Q
    77         ;
    78 CLIN    ; -- get clinic details
    79         N SC,SCFLE,SCIEN,SCDEF
    80         S SCFLE=44,SCIEN=SCID_",",SCDEF="<none specified>"
    81         D GETS^DIQ(SCFLE,SCID_",","1;3.5","","SC")
    82         D SET("Abbreviation: "_$S($G(SC(SCFLE,SCIEN,1))]"":SC(SCFLE,SCIEN,1),1:SCDEF),.SCINC,.SCDATA)
    83         D SET("    Division: "_$S($G(SC(SCFLE,SCIEN,3.5))]"":SC(SCFLE,SCIEN,3.5),1:SCDEF),.SCINC,.SCDATA)
    84         D SET(" ",.SCINC,.SCDATA)
    85         D SET("Associated Teams and Positions:",.SCINC,.SCDATA)
    86         D SET("-------------------------------",.SCINC,.SCDATA)
    87         S SCI=0 F  S SCI=$O(^SCTM(404.57,"E",SCID,SCI)) Q:'SCI  D
    88         . S X=$G(^SCTM(404.57,SCI,0))
    89         . D SET("      Team: "_$P($G(^SCTM(404.51,+$P(X,U,2),0)),U),.SCINC,.SCDATA)
    90         . D SET("  Position: "_$P(X,U),.SCINC,.SCDATA)
    91         . D SET(" ",.SCINC,.SCDATA)
    92         Q
    93         ;
    94 USER    ; -- get user class details
    95         D SET("No additional information available at this time. ",.SCINC,.SCDATA)
    96         Q
    97         ;
     1SCRPBK11 ;MJK/ALB - RPC Broker Utilities ; 27 FEB 96
     2 ;;5.3;Scheduling;**41**;AUG 13, 1993
     3 ;
     4GETSEL(SCDATA,SCTYPE,SCIEN) ;
     5 ; -- get SELECTION entity data for details form
     6 ;
     7 ;  input:  SCTYPE       := type of autolink (DIVISIOND, TEAM, ectc.)
     8 ;          SCIEN        := ien of entity
     9 ; output:  SCDATA(1..n) := info about entity
     10 ;
     11 ; -- SEE BOTTOM OF SCRPBK FOR VARIABLE DEFINITIONS
     12 ;
     13 ; Related RPC: SCRP FILE ENTRY GETSELECTION
     14 ;                   
     15 N SC0,SCI,SCINC
     16 S SCINC=0,SCID=+SCIEN
     17 ;
     18 IF SCTYPE="DIVISION" D DIV G GETSELQ
     19 ;
     20 IF SCTYPE="TEAM" D TEAM G GETSELQ
     21 ;
     22 IF SCTYPE="PRACTITIONER" D PRAC G GETSELQ
     23 ;
     24 IF SCTYPE="ROLE" D ROLE G GETSELQ
     25 ;
     26 IF SCTYPE="CLINIC" D CLIN G GETSELQ
     27 ;
     28 IF SCTYPE="USERCLASS" D USER G GETSELQ
     29 ;
     30GETSELQ Q
     31 ;
     32SET(X,INC,SCDATA) ; -- set value in return array
     33 S INC=$G(INC)+1,SCDATA(INC)=X
     34 Q
     35 ;
     36DIV ; -- get division details
     37 D SET("Teams in  Division:",.SCINC,.SCDATA)
     38 D SET("------------------",.SCINC,.SCDATA)
     39 S SCI=0 F  S SCI=$O(^SCTM(404.51,"AINST",SCID,SCI)) Q:'SCI  D
     40 . D SET($P($G(^SCTM(404.51,SCI,0)),U),.SCINC,.SCDATA)
     41 Q
     42 ;
     43TEAM ; -- get team description
     44 N SC,SCFLE,SCIEN,SCDEF
     45 S SCFLE=404.51,SCIEN=SCID_",",SCDEF="<none specified>"
     46 D GETS^DIQ(SCFLE,SCID_",",50,"","SC")
     47 D SET("Team Description:",.SCINC,.SCDATA)
     48 D SET("-----------------",.SCINC,.SCDATA)
     49 IF $O(SC(SCFLE,SCIEN,50,0)) D
     50 . S SCI=0 F  S SCI=$O(SC(SCFLE,SCIEN,50,SCI)) Q:'SCI  S X=SC(SCFLE,SCIEN,50,SCI) D
     51 . . D SET(X,.SCINC,.SCDATA)
     52 ELSE  D
     53 . D SET(SCDEF,.SCINC,.SCDATA)
     54 Q
     55 ;
     56PRAC ; -- get practitioner details
     57 N SC,SCFLE,SCIEN,SCDEF
     58 S SCFLE=200,SCIEN=SCID_",",SCDEF="<none specified>"
     59 D GETS^DIQ(SCFLE,SCID_",","1;8;28","","SC")
     60 D SET(" Initials: "_$S($G(SC(SCFLE,SCIEN,1))]"":SC(SCFLE,SCIEN,1),1:SCDEF),.SCINC,.SCDATA)
     61 D SET("Mail Code: "_$S($G(SC(SCFLE,SCIEN,28))]"":SC(SCFLE,SCIEN,28),1:SCDEF),.SCINC,.SCDATA)
     62 D SET("    Title: "_$S($G(SC(SCFLE,SCIEN,8))]"":SC(SCFLE,SCIEN,8),1:SCDEF),.SCINC,.SCDATA)
     63 Q
     64 ;
     65ROLE ; -- get standard role description
     66 N SC,SCFLE,SCIEN,SCDEF
     67 S SCFLE=403.46,SCIEN=SCID_",",SCDEF="<none specified>"
     68 D GETS^DIQ(SCFLE,SCID_",",1,"","SC")
     69 D SET("Role Description:",.SCINC,.SCDATA)
     70 D SET("-----------------",.SCINC,.SCDATA)
     71 IF $O(SC(SCFLE,SCIEN,1,0)) D
     72 . S SCI=0 F  S SCI=$O(SC(SCFLE,SCIEN,1,SCI)) Q:'SCI  S X=SC(SCFLE,SCIEN,1,SCI) D
     73 . . D SET(X,.SCINC,.SCDATA)
     74 ELSE  D
     75 . D SET(SCDEF,.SCINC,.SCDATA)
     76 Q
     77 ;
     78CLIN ; -- get clinic details
     79 N SC,SCFLE,SCIEN,SCDEF
     80 S SCFLE=44,SCIEN=SCID_",",SCDEF="<none specified>"
     81 D GETS^DIQ(SCFLE,SCID_",","1;3.5","","SC")
     82 D SET("Abbreviation: "_$S($G(SC(SCFLE,SCIEN,1))]"":SC(SCFLE,SCIEN,1),1:SCDEF),.SCINC,.SCDATA)
     83 D SET("    Division: "_$S($G(SC(SCFLE,SCIEN,3.5))]"":SC(SCFLE,SCIEN,3.5),1:SCDEF),.SCINC,.SCDATA)
     84 D SET(" ",.SCINC,.SCDATA)
     85 D SET("Assoicated Teams and Positions:",.SCINC,.SCDATA)
     86 D SET("-------------------------------",.SCINC,.SCDATA)
     87 S SCI=0 F  S SCI=$O(^SCTM(404.57,"D",SCID,SCI)) Q:'SCI  D
     88 . S X=$G(^SCTM(404.57,SCI,0))
     89 . D SET("      Team: "_$P($G(^SCTM(404.51,+$P(X,U,2),0)),U),.SCINC,.SCDATA)
     90 . D SET("  Position: "_$P(X,U),.SCINC,.SCDATA)
     91 . D SET(" ",.SCINC,.SCDATA)
     92 Q
     93 ;
     94USER ; -- get user class details
     95 D SET("No additional information available at this time. ",.SCINC,.SCDATA)
     96 Q
     97 ;

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPEC.m

    r613 r623  
    1 SCRPEC  ;ALB/CMM - Detail List of Pts & Enroll Clinics ; 29 Jun 99  04:11PM
    2         ;;5.3;Scheduling;**41,140,174,177,431,526,520**;AUG 13, 1993;Build 26
    3         ;
    4         ;Detailed Listing of Patients and Their Enrolled Clinics Report
    5         ;
    6 PROMPTS ;
    7         ;Prompt for Institution, Team, Clinic, Assigned or Unassigned to Primary
    8         ;Care, and Print device
    9         ;
    10         N VAUTD,VAUTT,VAUTC,VAUTA,QTIME,PRNT
    11         K VAUTD,VAUTT,VAUTC,VAUTA,VAUTCA,SCUP
    12         S QTIME=""
    13         W ! D INST^SCRPU1 I Y=-1 G ERR
    14         W ! K Y D PRMTT^SCRPU1 I '$D(VAUTT) G ERR
    15         ;S VAUTCA="" ;allows for selection of any clinic in one of the selected divisions
    16         W ! K Y D CLINIC^SCRPU1 I '$D(VAUTC) G ERR
    17         W ! K Y D ASSUN^SCRPU2 I '$D(VAUTA) G ERR
    18         W !!,"This report requires 132 column output!"
    19         D QUE(.VAUTD,.VAUTT,.VAUTC,.VAUTA) Q
    20         ;
    21 QUE(INST,TEAM,CLINIC,ASSUN)     ;queue report
    22         ;Input Parameters:
    23         ;INST - institutions selected (variable and array)
    24         ;TEAM - teams selected (variable and array)
    25         ;CLINIC - clinics selected (variable and array)
    26         ;ASSUN - Assigned or Unassigned to PC
    27         N ZTSAVE,II
    28         F II="INST","TEAM","CLINIC","ASSUN","INST(","TEAM(","CLINIC(" S ZTSAVE(II)=""
    29         W ! D EN^XUTMDEVQ("QENTRY^SCRPEC","Detailed Patient Enrollments",.ZTSAVE)
    30         Q
    31         ;
    32 ENTRY2(INST,TEAM,CLINIC,ASSUN,IOP,ZTDTH)        ;
    33         ;Second entry point for GUI to use
    34         ;Input Parameters:
    35         ;INST - institutions selected (variable and array)
    36         ;TEAM - teams selected (variable and array)
    37         ;CLINIC - clinics selected (variable and array)
    38         ;ASSUN - Assigned or Unassigned to PC
    39         ;IOP - print device
    40         ;ZTDTH - queue time (optional)
    41         ;
    42         ;validate parameters
    43         I '$D(INST)!'$D(TEAM)!'$D(CLINIC)!'$D(ASSUN)!'$D(IOP)!(IOP="") Q
    44         ;
    45         N NUMBER
    46         S IOST=$P(IOP,"^",2),IOP=$P(IOP,"^")
    47         I IOP?1"Q;".E S IOP=$P(IOP,"Q;",2)
    48         I IOST?1"C-".E D QENTRY G RET
    49         I ZTDTH="" S ZTDTH=$H
    50         S ZTRTN="QENTRY^SCRPEC"
    51         S ZTDESC="Detailed Patient List & Enrolled Clinics",ZTIO=IOP
    52         N II
    53         F II="INST","TEAM","CLINIC","ASSUN","INST(","TEAM(","CLINIC(","IOP" S ZTSAVE(II)=""
    54         D ^%ZTLOAD
    55 RET     S NUMBER=0
    56         I $D(ZTSK) S NUMBER=ZTSK
    57         D EXIT1
    58         Q NUMBER
    59         ;
    60 QENTRY  ;
    61         ;driver entry point
    62         S VAUTTN=""
    63         S TITL="Detailed Patient Assignments - "_$S(ASSUN=1:"Assigned PC",1:"Not Assigned PC")
    64         S STORE="^TMP("_$J_",""SCRPEC"")"
    65         K @STORE
    66         S @STORE=0
    67         D FIND^SCRPEC3
    68         I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL)
    69         I '$D(NODATA) D HEADER^SCRPEC2,PRINTIT^SCRPEC3(STORE,TITL)
    70         D EXIT2
    71         Q
    72         ;
    73 ERR     ;
    74 EXIT1   ;
    75         K ZTSAVE,ZTSK,ZTIO,ZTDTH,ZTRTN,ZTDESC,VAUTCA,SCUP
    76         Q
    77 EXIT2   ;
    78         K @STORE
    79         K STORE,VAUTTN,PAGE,TITL,IOP,TITL,NODATA,CLINIC,ASSUN,INST,TEAM,STOP
    80         Q
    81         ;
    82 PDATA(DFN,CLNEN,CNAME,FLAG)     ;
    83         ;Collect and format data for report
    84         ;
    85         N NODE,NAME,PID,PELIG,MT,PSTAT,STATD,DATA,LAST,NEXT
    86         S DATA=""
    87         S NODE=$G(^DPT(DFN,0))
    88         S NAME=$P(NODE,"^") ;patient name
    89         S PID=$P($G(^DPT(DFN,.36)),"^",3),PID=$TR(PID,"-","") ;PID without '-'s
    90         S MT=$$LST^DGMTU(DFN),MT=$P(MT,"^",4)  ;means test status SD*5.3*431
    91         S PELIG=$$ELIG^SCRPU3(DFN) ;primary eligibility
    92         S PSTAT="N/A"
    93         S STATD=""
    94         S LAST=$$GETLAST^SCRPU3(DFN,.CLNEN) ;last Clinic appointment
    95         S NEXT=$$GETNEXT^SCRPU3(DFN,.CLNEN) ;next clinic appointment
    96         ;I '$D(FLAG) S DATA=$$FORMAT^SCRPEC2(PTIEN,INS,TIEN,PDATA,CNAME,CIEN)
    97         I '$D(FLAG) S DATA=$$FORMAT^SCRPEC2(NAME,PID,MT,PELIG,PSTAT,STATD,LAST,NEXT,CNAME),DATA=$E(NAME,1,12)_"^"_DATA
    98         I $D(FLAG) S DATA=$E(NAME,1,12)_"^"_PID_"^"_MT_"^"_PELIG_"^"_PSTAT_"^"_STATD_"^"_LAST_"^"_NEXT
    99         Q DATA
    100         ;
     1SCRPEC ;ALB/CMM - Detail List of Pts & Enroll Clinics ; 29 Jun 99  04:11PM
     2 ;;5.3;Scheduling;**41,140,174,177,431**;AUG 13, 1993
     3 ;
     4 ;Detailed Listing of Patients and Their Enrolled Clinics Report
     5 ;
     6PROMPTS ;
     7 ;Prompt for Institution, Team, Clinic, Assigned or Unassigned to Primary
     8 ;Care, and Print device
     9 ;
     10 N VAUTD,VAUTT,VAUTC,VAUTA,QTIME,PRNT
     11 K VAUTD,VAUTT,VAUTC,VAUTA,VAUTCA,SCUP
     12 S QTIME=""
     13 W ! D INST^SCRPU1 I Y=-1 G ERR
     14 W ! K Y D PRMTT^SCRPU1 I '$D(VAUTT) G ERR
     15 ;S VAUTCA="" ;allows for selection of any clinic in one of the selected divisions
     16 W ! K Y D CLINIC^SCRPU1 I '$D(VAUTC) G ERR
     17 W ! K Y D ASSUN^SCRPU2 I '$D(VAUTA) G ERR
     18 W !!,"This report requires 132 column output!"
     19 D QUE(.VAUTD,.VAUTT,.VAUTC,.VAUTA) Q
     20 ;
     21QUE(INST,TEAM,CLINIC,ASSUN) ;queue report
     22 ;Input Parameters:
     23 ;INST - institutions selected (variable and array)
     24 ;TEAM - teams selected (variable and array)
     25 ;CLINIC - clinics selected (variable and array)
     26 ;ASSUN - Assigned or Unassigned to PC
     27 N ZTSAVE,II
     28 F II="INST","TEAM","CLINIC","ASSUN","INST(","TEAM(","CLINIC(" S ZTSAVE(II)=""
     29 W ! D EN^XUTMDEVQ("QENTRY^SCRPEC","Detailed Patient Enrollments",.ZTSAVE)
     30 Q
     31 ;
     32ENTRY2(INST,TEAM,CLINIC,ASSUN,IOP,ZTDTH) ;
     33 ;Second entry point for GUI to use
     34 ;Input Parameters:
     35 ;INST - institutions selected (variable and array)
     36 ;TEAM - teams selected (variable and array)
     37 ;CLINIC - clinics selected (variable and array)
     38 ;ASSUN - Assigned or Unassigned to PC
     39 ;IOP - print device
     40 ;ZTDTH - queue time (optional)
     41 ;
     42 ;validate parameters
     43 I '$D(INST)!'$D(TEAM)!'$D(CLINIC)!'$D(ASSUN)!'$D(IOP)!(IOP="") Q
     44 ;
     45 N NUMBER
     46 S IOST=$P(IOP,"^",2),IOP=$P(IOP,"^")
     47 I IOP?1"Q;".E S IOP=$P(IOP,"Q;",2)
     48 I IOST?1"C-".E D QENTRY G RET
     49 I ZTDTH="" S ZTDTH=$H
     50 S ZTRTN="QENTRY^SCRPEC"
     51 S ZTDESC="Detailed Patient List & Enrolled Clinics",ZTIO=IOP
     52 N II
     53 F II="INST","TEAM","CLINIC","ASSUN","INST(","TEAM(","CLINIC(","IOP" S ZTSAVE(II)=""
     54 D ^%ZTLOAD
     55RET S NUMBER=0
     56 I $D(ZTSK) S NUMBER=ZTSK
     57 D EXIT1
     58 Q NUMBER
     59 ;
     60QENTRY ;
     61 ;driver entry point
     62 S VAUTTN=""
     63 S TITL="Detailed Patient Assignments - "_$S(ASSUN=1:"Assigned PC",1:"Not Assigned PC")
     64 S STORE="^TMP("_$J_",""SCRPEC"")"
     65 K @STORE
     66 S @STORE=0
     67 D FIND^SCRPEC3
     68 I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL)
     69 I '$D(NODATA) D HEADER^SCRPEC2,PRINTIT^SCRPEC3(STORE,TITL)
     70 D EXIT2
     71 Q
     72 ;
     73ERR ;
     74EXIT1 ;
     75 K ZTSAVE,ZTSK,ZTIO,ZTDTH,ZTRTN,ZTDESC,VAUTCA,SCUP
     76 Q
     77EXIT2 ;
     78 K @STORE
     79 K STORE,VAUTTN,PAGE,TITL,IOP,TITL,NODATA,CLINIC,ASSUN,INST,TEAM,STOP
     80 Q
     81 ;
     82PDATA(DFN,CLNEN,FLAG) ;
     83 ;Collect and format data for report
     84 ;
     85 N NODE,NAME,PID,PELIG,MT,PSTAT,STATD,DATA,LAST,NEXT,CEN,CNAME
     86 S DATA=""
     87 S NODE=$G(^DPT(DFN,0))
     88 S NAME=$P(NODE,"^") ;patient name
     89 S PID=$P($G(^DPT(DFN,.36)),"^",3),PID=$TR(PID,"-","") ;PID without '-'s
     90 S MT=$$LST^DGMTU(DFN),MT=$P(MT,"^",4)  ;means test status SD*5.3*431
     91 S PELIG=$$ELIG^SCRPU3(DFN) ;primary eligibility
     92 ;
     93 S CNAME=$P($G(^SC(CLNEN,0)),"^")
     94 S CEN=+$O(^DPT(DFN,"DE","B",CLNEN,""))
     95 S NODE=$G(^DPT(DFN,"DE",CEN,1,1,0))
     96 S PSTAT=$P(NODE,"^",2) S PSTAT=PSTAT_$S(PSTAT="A":"C",PSTAT="O":"PT",1:"") ;opt or ac status
     97 I $P(NODE,"^")="" S STATD=""
     98 I $P(NODE,"^")'="" S STATD=$TR($$FMTE^XLFDT($P(NODE,"^"),"5DF")," ","0") ;enrollment date
     99 S LAST=$$GETLAST^SCRPU3(DFN,CLNEN) ;last clinic appointment
     100 S NEXT=$$GETNEXT^SCRPU3(DFN,CLNEN) ;next clinic appointment
     101 I '$D(FLAG) S DATA=$$FORMAT^SCRPEC2(NAME,PID,MT,PELIG,PSTAT,STATD,LAST,NEXT,CNAME),DATA=$E(NAME,1,20)_"^"_DATA
     102 I $D(FLAG) S DATA=$E(NAME,1,20)_"^"_PID_"^"_MT_"^"_PELIG_"^"_PSTAT_"^"_STATD_"^"_LAST_"^"_NEXT
     103 Q DATA
     104 ;

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPEC2.m

    r613 r623  
    1 SCRPEC2 ;ALB/CMM - Detail List of Pts & Enroll Clinics Continued ; 29 Jun 99  04:11PM
    2         ;;5.3;Scheduling;**41,140,174,177,526**;AUG 13, 1993;Build 8
    3         ;
    4         ;Detailed Listing of Patients and Their Enrolled Clinics Report
    5         ;
    6 PAT(TIEN,PTLIST)        ;
    7         ;TIEN - team ien
    8         ;PTLIST - array holding patients assigned to team TIEN
    9         ;
    10         N PTIEN,ENT,NODE,OKAY,CLLIST,ERR,PC
    11         S ENT=0,CLLIST="LIST2",ERR="ERROR2"
    12         K @CLLIST
    13         F  S ENT=$O(@PTLIST@(ENT)) Q:ENT=""!(ENT'?.N)  D
    14         .S NODE=$G(@PTLIST@(ENT))
    15         .Q:NODE=""
    16         .S PTIEN=+$P(NODE,"^") ;patient ien
    17         .S PC=$$PCASSIGN(PTIEN,TIEN)
    18         .Q:PC'=ASSUN  ;not selected assigned/unassigned primary care
    19         .K @CLLIST
    20         .S OKAY=$$CLPT^SCAPMC29(PTIEN,"","",.CLLIST,.ERR)
    21         .;all clinics for patient PTIEN
    22         .Q:'OKAY
    23         .D KEEP(TIEN,PTIEN,.CLLIST)
    24         K @CLLIST
    25         Q
    26         ;
    27 KEEP(TIEN,PTIEN,CLLIST) ;keep data for report
    28         ;TIEN - team ien
    29         ;PTIEN - patient ien
    30         ;CLLIST - array holding clinics for patient PTIEN
    31         ;
    32         N ENT,TNAME,INS,NODE,INAME,PDATA,NODE,CIEN,CNAME,PNAME
    33         N SCPCPR,SCPCAP,SCI,PCLIST
    34         S TNAME=$P($G(^SCTM(404.51,TIEN,0)),"^") ;team name
    35         S INS=+$P($G(^SCTM(404.51,TIEN,0)),"^",7) ;institution ien
    36         S INAME=$P($G(^DIC(4,INS,0)),"^") ;institution name
    37         S PNAME=$P($G(^DPT(PTIEN,0)),"^") ;patient name
    38         K ^TMP("SC",$J,PTIEN)
    39         S SCI=$$GETALL^SCAPMCA(PTIEN) D
    40         .;Name of PC Provider
    41         .S SCPCPR=$P($G(^TMP("SC",$J,PTIEN,"PCPR",1)),U,2)
    42         .;Name of Associate Provider
    43         .S SCPCAP=$P($G(^TMP("SC",$J,PTIEN,"PCAP",1)),U,2)
    44         .Q
    45         ;
    46         S ENT=0
    47         F  S ENT=$O(@CLLIST@(ENT)) Q:ENT=""!(ENT'?.N)  D
    48         .S NODE=$G(@CLLIST@(ENT))
    49         .S CIEN=+$P(NODE,"^") ;clinic ien
    50         .I CLINIC'=1,'$D(CLINIC(CIEN)) Q
    51         .S CNAME=$P(NODE,"^",2) ;clinic name
    52         .D SETUP(INS,INAME,TIEN,TNAME,PTIEN,PNAME,CIEN,CNAME)
    53         .S PDATA=$$PDATA^SCRPEC(PTIEN,CIEN,1)
    54         .S $P(PDATA,U,9)=SCPCPR,$P(PDATA,U,10)=SCPCAP
    55         .;name^pid^mt^pelig^pstat^statd^last^next^pc prov.^assoc. prov.
    56         .D FORMAT(PTIEN,INS,TIEN,PDATA,CNAME,CIEN)
    57         Q
    58         ;
    59 SETUP(INS,INAME,TIEN,TNAME,PTIEN,PNAME,CIEN,CNAME)      ;
    60         ;INS - institution ien
    61         ;INAME - institution name
    62         ;TIEN - team ien
    63         ;TNAME - team name
    64         ;PTIEN - patient ien
    65         ;PNAME - patient name
    66         ;CIEN - clinic ien
    67         ;CNAME - clinic name
    68         ;
    69         I INAME="" S INAME="[BAD DATA]"
    70         I TNAME="" S TNAME="[BAD DATA]"
    71         I CNAME="" S CNAME="[BAD DATA]"
    72         I PNAME="" S PNAME="[BAD DATA]"
    73         I '$D(@STORE@("I",INAME,INS)) S @STORE@("I",INAME,INS)="",@STORE@(INS)="Division: "_INAME
    74         I '$D(@STORE@("T",INS,TNAME,TIEN)) S @STORE@("T",INS,TNAME,TIEN)="",@STORE@(INS,TIEN)="Team: "_TNAME
    75         I '$D(@STORE@("C",INS,TIEN,CNAME,CIEN)) S @STORE@("C",INS,TIEN,CNAME,CIEN)="" ;D HEADER(INS,TIEN,CIEN)
    76         I '$D(@STORE@("PT",INS,TIEN,CIEN,PNAME,PTIEN)) S @STORE@("PT",INS,TIEN,CIEN,PNAME,PTIEN)=""
    77         Q
    78         ;
    79 PCASSIGN(DFN,TIEN)      ;patient assigned to team as primary care
    80         ;DFN - patient ien
    81         ;TIEN - team ien
    82         ;1 - yes
    83         ;0 - no
    84         ;
    85         N ADATE,ENTRY,PC
    86         S PC=0
    87         I '$D(^SCPT(404.42,"AIDT",DFN,TIEN)) Q PC
    88         S ADATE=$O(^SCPT(404.42,"AIDT",DFN,TIEN,"")) ; -team assignemtn date
    89         S ENTRY=$O(^SCPT(404.42,"AIDT",DFN,TIEN,ADATE,"")) ;patient team assignemtn ien
    90         I $P($G(^SCPT(404.42,+ENTRY,0)),"^",8)=1 S PC=1
    91         Q PC
    92         ;
    93 HEADER  ;report column titles
    94         N HLD
    95         S HLD="H0"
    96         S $E(@STORE@("SUBHEADER",HLD),25)="M.T."
    97         S $E(@STORE@("SUBHEADER",HLD),31)="Prim"
    98         ;Removed by patch 174
    99         ;S $E(@STORE@("SUBHEADER",HLD),31)="Pat"
    100         ;S $E(@STORE@("SUBHEADER",HLD),36)="Status"
    101         S $E(@STORE@("SUBHEADER",HLD),42)="Last"
    102         S $E(@STORE@("SUBHEADER",HLD),54)="Next"
    103         S $E(@STORE@("SUBHEADER",HLD),66)="Enrolled"
    104         S $E(@STORE@("SUBHEADER",HLD),95)="Primary Care"
    105         S $E(@STORE@("SUBHEADER",HLD),115)="Associate"
    106         S HLD="H1"
    107         S @STORE@("SUBHEADER",HLD)="Patient Name"
    108         S $E(@STORE@("SUBHEADER",HLD),16)="Pt ID"
    109         S $E(@STORE@("SUBHEADER",HLD),25)="Stat"
    110         S $E(@STORE@("SUBHEADER",HLD),31)="Elig"
    111         ;Removed by patch 174
    112         ;S $E(@STORE@("SUBHEADER",HLD),31)="Stat"
    113         ;S $E(@STORE@("SUBHEADER",HLD),36)="Date"
    114         S $E(@STORE@("SUBHEADER",HLD),42)="Appt"
    115         S $E(@STORE@("SUBHEADER",HLD),54)="Appt"
    116         S $E(@STORE@("SUBHEADER",HLD),66)="Clinic"
    117         S $E(@STORE@("SUBHEADER",HLD),95)="Provider"
    118         S $E(@STORE@("SUBHEADER",HLD),115)="Provider"
    119         S HLD="H2"
    120         S $P(@STORE@("SUBHEADER",HLD),"=",133)=""
    121         Q
    122         ;
    123 FORMAT(PTIEN,INS,TIEN,PDATA,CNAME,CIEN) ;format data for report
    124         ;PTIEN - patient ien
    125         ;INS - institution ien
    126         ;TIEN - team ien
    127         ;PDATA - pt name^pid^mt^pelig^pstat^statd^last^next^pc prov.^assoc. prov.
    128         ;CNAME - clinic name
    129         ;CIEN - clinic ien
    130         ;
    131         S @STORE@(INS,TIEN,CIEN,PTIEN)=$E($P(PDATA,"^"),1,12) ;patient name
    132         S $E(@STORE@(INS,TIEN,CIEN,PTIEN),14)=$P(PDATA,"^",2) ;primary long id 9 digit
    133         S $E(@STORE@(INS,TIEN,CIEN,PTIEN),26)=$P(PDATA,"^",3) ;means test category
    134         S $E(@STORE@(INS,TIEN,CIEN,PTIEN),31)=$P(PDATA,"^",4) ;primary eligibility
    135         ;Removed by patch 174
    136         ;S $E(@STORE@(INS,TIEN,CIEN,PTIEN),31)=$P(PDATA,"^",5) ;patient status
    137         ;S $E(@STORE@(INS,TIEN,CIEN,PTIEN),35)=$P(PDATA,"^",6) ;status date
    138         S $E(@STORE@(INS,TIEN,CIEN,PTIEN),42)=$P(PDATA,"^",7) ;last appointment
    139         S $E(@STORE@(INS,TIEN,CIEN,PTIEN),54)=$P(PDATA,"^",8) ;next appointment
    140         S $E(@STORE@(INS,TIEN,CIEN,PTIEN),66)=$E(CNAME,1,27) ;clinic name
    141         S $E(@STORE@(INS,TIEN,CIEN,PTIEN),95)=$E($P(PDATA,U,9),1,18) ;PC prov.
    142         S $E(@STORE@(INS,TIEN,CIEN,PTIEN),115)=$E($P(PDATA,U,10),1,18) ;Assoc. Prov.
    143         Q
    144         ;
    145 CHEAD(INS,TEAM,CLINIC)  ;
    146         ;column headings
    147         ;
    148         N EN,NEWP
    149         W !
    150         S NEWP=0
    151         I IOST'?1"C-".E,$Y+5>(IOSL-6) D NEWP1^SCRPU3(.PAGE,TITL) S NEWP=1
    152         I IOST?1"C-".E,$Y+5>(IOSL-6) D HOLD^SCRPU3(.PAGE,TITL) S NEWP=1
    153         I STOP Q
    154         I NEWP W !,$G(@STORE@(INS)),!!,$G(@STORE@(INS,TEAM)),!
    155 CH2     F EN="H0","H1","H2" W !,$G(@STORE@("SUBHEADER",EN))
    156         Q
    157         ;
     1SCRPEC2 ;ALB/CMM - Detail List of Pts & Enroll Clinics Continued ; 29 Jun 99  04:11PM
     2 ;;5.3;Scheduling;**41,140,174,177**;AUG 13, 1993
     3 ;
     4 ;Detailed Listing of Patients and Their Enrolled Clinics Report
     5 ;
     6PAT(TIEN,PTLIST) ;
     7 ;TIEN - team ien
     8 ;PTLIST - array holding patients assigned to team TIEN
     9 ;
     10 N PTIEN,ENT,NODE,OKAY,CLLIST,ERR,PC
     11 S ENT=0,CLLIST="LIST2",ERR="ERROR2"
     12 K @CLLIST
     13 F  S ENT=$O(@PTLIST@(ENT)) Q:ENT=""!(ENT'?.N)  D
     14 .S NODE=$G(@PTLIST@(ENT))
     15 .Q:NODE=""
     16 .S PTIEN=+$P(NODE,"^") ;patient ien
     17 .S PC=$$PCASSIGN(PTIEN,TIEN)
     18 .Q:PC'=ASSUN  ;not selected assigned/unassigned primary care
     19 .K @CLLIST
     20 .S OKAY=$$CLPT^SCAPMC29(PTIEN,"","",.CLLIST,.ERR)
     21 .;all clinics for patient PTIEN
     22 .Q:'OKAY
     23 .D KEEP(TIEN,PTIEN,.CLLIST)
     24 K @CLLIST
     25 Q
     26 ;
     27KEEP(TIEN,PTIEN,CLLIST) ;keep data for report
     28 ;TIEN - team ien
     29 ;PTIEN - patient ien
     30 ;CLLIST - array holding clinics for patient PTIEN
     31 ;
     32 N ENT,TNAME,INS,NODE,INAME,PDATA,NODE,CIEN,CNAME,PNAME
     33 N SCPCPR,SCPCAP,SCI,PCLIST
     34 S TNAME=$P($G(^SCTM(404.51,TIEN,0)),"^") ;team name
     35 S INS=+$P($G(^SCTM(404.51,TIEN,0)),"^",7) ;institution ien
     36 S INAME=$P($G(^DIC(4,INS,0)),"^") ;institution name
     37 S PNAME=$P($G(^DPT(PTIEN,0)),"^") ;patient name
     38 K ^TMP("SC",$J,PTIEN)
     39 S SCI=$$GETALL^SCAPMCA(PTIEN) D
     40 .;Name of PC Provider
     41 .S SCPCPR=$P($G(^TMP("SC",$J,PTIEN,"PCPR",1)),U,2)
     42 .;Name of Associate Provider
     43 .S SCPCAP=$P($G(^TMP("SC",$J,PTIEN,"PCAP",1)),U,2)
     44 .Q
     45 ;
     46 S ENT=0
     47 F  S ENT=$O(@CLLIST@(ENT)) Q:ENT=""!(ENT'?.N)  D
     48 .S NODE=$G(@CLLIST@(ENT))
     49 .S CIEN=+$P(NODE,"^") ;clinic ien
     50 .I CLINIC'=1,'$D(CLINIC(CIEN)) Q
     51 .S CNAME=$P(NODE,"^",2) ;clinic name
     52 .D SETUP(INS,INAME,TIEN,TNAME,PTIEN,PNAME,CIEN,CNAME)
     53 .S PDATA=$$PDATA^SCRPEC(PTIEN,CIEN,1)
     54 .S $P(PDATA,U,9)=SCPCPR,$P(PDATA,U,10)=SCPCAP
     55 .;name^pid^mt^pelig^pstat^statd^last^next^pc prov.^assoc. prov.
     56 .D FORMAT(PTIEN,INS,TIEN,PDATA,CNAME,CIEN)
     57 Q
     58 ;
     59SETUP(INS,INAME,TIEN,TNAME,PTIEN,PNAME,CIEN,CNAME) ;
     60 ;INS - institution ien
     61 ;INAME - institution name
     62 ;TIEN - team ien
     63 ;TNAME - team name
     64 ;PTIEN - patient ien
     65 ;PNAME - patient name
     66 ;CIEN - clinic ien
     67 ;CNAME - clinic name
     68 ;
     69 I INAME="" S INAME="[BAD DATA]"
     70 I TNAME="" S TNAME="[BAD DATA]"
     71 I CNAME="" S CNAME="[BAD DATA]"
     72 I PNAME="" S PNAME="[BAD DATA]"
     73 I '$D(@STORE@("I",INAME,INS)) S @STORE@("I",INAME,INS)="",@STORE@(INS)="Division: "_INAME
     74 I '$D(@STORE@("T",INS,TNAME,TIEN)) S @STORE@("T",INS,TNAME,TIEN)="",@STORE@(INS,TIEN)="Team: "_TNAME
     75 I '$D(@STORE@("C",INS,TIEN,CNAME,CIEN)) S @STORE@("C",INS,TIEN,CNAME,CIEN)="" ;D HEADER(INS,TIEN,CIEN)
     76 I '$D(@STORE@("PT",INS,TIEN,CIEN,PNAME,PTIEN)) S @STORE@("PT",INS,TIEN,CIEN,PNAME,PTIEN)=""
     77 Q
     78 ;
     79PCASSIGN(DFN,TIEN) ;patient assigned to team as primary care
     80 ;DFN - patient ien
     81 ;TIEN - team ien
     82 ;1 - yes
     83 ;0 - no
     84 ;
     85 N ADATE,ENTRY,PC
     86 S PC=0
     87 I '$D(^SCPT(404.42,"AIDT",DFN,TIEN)) Q PC
     88 S ADATE=$O(^SCPT(404.42,"AIDT",DFN,TIEN,"")) ; -team assignemtn date
     89 S ENTRY=$O(^SCPT(404.42,"AIDT",DFN,TIEN,ADATE,"")) ;patient team assignemtn ien
     90 I $P($G(^SCPT(404.42,+ENTRY,0)),"^",8)=1 S PC=1
     91 Q PC
     92 ;
     93HEADER ;report column titles
     94 N HLD
     95 S HLD="H0"
     96 S $E(@STORE@("SUBHEADER",HLD),25)="M.T."
     97 S $E(@STORE@("SUBHEADER",HLD),31)="Prim"
     98 ;Removed by patch 174
     99 ;S $E(@STORE@("SUBHEADER",HLD),31)="Pat"
     100 ;S $E(@STORE@("SUBHEADER",HLD),36)="Status"
     101 S $E(@STORE@("SUBHEADER",HLD),42)="Last"
     102 S $E(@STORE@("SUBHEADER",HLD),54)="Next"
     103 S $E(@STORE@("SUBHEADER",HLD),66)="Enrolled"
     104 S $E(@STORE@("SUBHEADER",HLD),95)="Primary Care"
     105 S $E(@STORE@("SUBHEADER",HLD),115)="Associate"
     106 S HLD="H1"
     107 S @STORE@("SUBHEADER",HLD)="Patient Name"
     108 S $E(@STORE@("SUBHEADER",HLD),18)="Pt ID"
     109 S $E(@STORE@("SUBHEADER",HLD),25)="Stat"
     110 S $E(@STORE@("SUBHEADER",HLD),31)="Elig"
     111 ;Removed by patch 174
     112 ;S $E(@STORE@("SUBHEADER",HLD),31)="Stat"
     113 ;S $E(@STORE@("SUBHEADER",HLD),36)="Date"
     114 S $E(@STORE@("SUBHEADER",HLD),42)="Appt"
     115 S $E(@STORE@("SUBHEADER",HLD),54)="Appt"
     116 S $E(@STORE@("SUBHEADER",HLD),66)="Clinic"
     117 S $E(@STORE@("SUBHEADER",HLD),95)="Provider"
     118 S $E(@STORE@("SUBHEADER",HLD),115)="Provider"
     119 S HLD="H2"
     120 S $P(@STORE@("SUBHEADER",HLD),"=",133)=""
     121 Q
     122 ;
     123FORMAT(PTIEN,INS,TIEN,PDATA,CNAME,CIEN) ;format data for report
     124 ;PTIEN - patient ien
     125 ;INS - institution ien
     126 ;TIEN - team ien
     127 ;PDATA - pt name^pid^mt^pelig^pstat^statd^last^next^pc prov.^assoc. prov.
     128 ;CNAME - clinic name
     129 ;CIEN - clinic ien
     130 ;
     131 S @STORE@(INS,TIEN,CIEN,PTIEN)=$E($P(PDATA,"^"),1,15) ;patient name
     132 S $E(@STORE@(INS,TIEN,CIEN,PTIEN),18)=$E($P(PDATA,"^",2),6,10) ;primary long id last 4 plus P
     133 S $E(@STORE@(INS,TIEN,CIEN,PTIEN),25)=$P(PDATA,"^",3) ;means test category
     134 S $E(@STORE@(INS,TIEN,CIEN,PTIEN),31)=$P(PDATA,"^",4) ;primary eligibility
     135 ;Removed by patch 174
     136 ;S $E(@STORE@(INS,TIEN,CIEN,PTIEN),31)=$P(PDATA,"^",5) ;patient status
     137 ;S $E(@STORE@(INS,TIEN,CIEN,PTIEN),35)=$P(PDATA,"^",6) ;status date
     138 S $E(@STORE@(INS,TIEN,CIEN,PTIEN),42)=$P(PDATA,"^",7) ;last appointment
     139 S $E(@STORE@(INS,TIEN,CIEN,PTIEN),54)=$P(PDATA,"^",8) ;next appointment
     140 S $E(@STORE@(INS,TIEN,CIEN,PTIEN),66)=$E(CNAME,1,27) ;clinic name
     141 S $E(@STORE@(INS,TIEN,CIEN,PTIEN),95)=$E($P(PDATA,U,9),1,18) ;PC prov.
     142 S $E(@STORE@(INS,TIEN,CIEN,PTIEN),115)=$E($P(PDATA,U,10),1,18) ;Assoc. Prov.
     143 Q
     144 ;
     145CHEAD(INS,TEAM,CLINIC) ;
     146 ;column headings
     147 ;
     148 N EN,NEWP
     149 W !
     150 S NEWP=0
     151 I IOST'?1"C-".E,$Y+5>(IOSL-6) D NEWP1^SCRPU3(.PAGE,TITL) S NEWP=1
     152 I IOST?1"C-".E,$Y+5>(IOSL-6) D HOLD^SCRPU3(.PAGE,TITL) S NEWP=1
     153 I STOP Q
     154 I NEWP W !,$G(@STORE@(INS)),!!,$G(@STORE@(INS,TEAM)),!
     155CH2 F EN="H0","H1","H2" W !,$G(@STORE@("SUBHEADER",EN))
     156 Q
     157 ;

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPITP.m

    r613 r623  
    1 SCRPITP ;ALB/CMM - Individual Team Profile ; 29 Jun 99  04:11PM
    2         ;;5.3;Scheduling;**41,52,177,520**;AUG 13, 1993;Build 26
    3         ;
    4         ;Individual Team Profile
    5         ;
    6 PROMPTS ;
    7         ;Prompt for Institution, Team, and Print device
    8         ;
    9         N QTIME,PRNT,VAUTD,VAUTT,Y,NUMBER
    10         K VAUTD,VAUTT,SCUP
    11         S QTIME=""
    12         W ! D INST^SCRPU1 I Y=-1 G ERR
    13         W ! K Y D PRMTT^SCRPU1 I '$D(VAUTT) G ERR
    14         W !!,"This report requires 132 column output!"
    15         D QUE(.VAUTD,.VAUTT) Q
    16         ;
    17 QUE(INST,TEAM)  ;queue report
    18         ;Input Parameters:
    19         ;INST - institutions selected (variable and array)
    20         ;TEAM - teams selected (variable and array)
    21         N ZTSAVE,II
    22         F II="INST","TEAM","INST(","TEAM(" S ZTSAVE(II)=""
    23         W ! D EN^XUTMDEVQ("QENTRY^SCRPITP","Individual Team Profile",.ZTSAVE)
    24         Q
    25         ;
    26 ENTRY2(INST,TEAM,IOP,ZTDTH)     ;
    27         ;Second entry point for GUI to use
    28         ;Input Parameters:
    29         ;INST - institutions selected (variable and array)
    30         ;TEAM - teams selected (variable and array)
    31         ;IOP - print device
    32         ;ZTDTH - queue time (optional)
    33         ;
    34         ;validate parameters
    35         I '$D(INST)!'$D(TEAM)!'$D(IOP)!(IOP="") Q
    36         ;
    37         N NUMBER
    38         S IOST=$P(IOP,"^",2),IOP=$P(IOP,"^")
    39         I IOP?1"Q;".E S IOP=$P(IOP,"Q;",2)
    40         I IOST?1"C-".E D QENTRY G RET
    41         I ZTDTH="" S ZTDTH=$H
    42         S ZTRTN="QENTRY^SCRPITP"
    43         S ZTDESC="iIndividual Team Profile",ZTIO=IOP
    44         N II
    45         F II="INST","TEAM","INST(","TEAM(","IOP" S ZTSAVE(II)=""
    46         D ^%ZTLOAD
    47 RET     S NUMBER=0
    48         I $D(ZTSK) S NUMBER=ZTSK
    49         D EXIT1
    50         Q NUMBER
    51         ;
    52 QENTRY  ;
    53         ;driver entry point
    54         S TITL="Individual Team Profile"
    55         S STORE="^TMP("_$J_",""SCRPITP"")"
    56         K @STORE
    57         S @STORE=0
    58         I TEAM=1 D TALL^SCRPPAT3 S TEAM=0
    59         D FIND
    60         I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL)
    61         I '$D(NODATA) D PRINTIT(STORE,TITL)
    62         D EXIT2
    63         Q
    64         ;
    65 ERR     ;
    66 EXIT1   ;
    67         K ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE
    68         Q
    69         ;
    70 EXIT2   ;
    71         K @STORE
    72         K STOP,STORE,TITL,IOP,TEAM,INST,NODATA
    73         Q
    74         ;
    75 FIND    ;
    76         N TM,EN,NODE,TMP,TPNAME
    77         S TM="" K ^TMP("SCRATCH",$J)
    78         F  S TM=$O(^SCTM(404.57,"C",TM)) Q:TM=""  D
    79         .;$O through team position file
    80         .I '$D(TEAM(TM))&(TEAM'=1) Q
    81         .;Q above, not a selected team
    82         .;selected team
    83         .S EN=""
    84         .F  S EN=$O(^SCTM(404.57,"C",TM,EN)) Q:EN=""  D
    85         ..I '$D(^SCTM(404.57,EN,0)) Q
    86         ..S NODE=$G(^SCTM(404.57,EN,0))
    87         ..Q:NODE=""
    88         ..;active or inactive position
    89         ..S TMP=$$DATES^SCAPMCU1(404.59,EN,DT)
    90         ..S TPNAME=$P(NODE,U) S:'$L(TPNAME) TPNAME="~~~"
    91         ..S ^TMP("SCRATCH",$J,TPNAME,EN)=NODE
    92         ..I +TMP S ^TMP("SCRATCH",$J,TM,TPNAME,EN)=NODE
    93         ..Q
    94         .Q
    95         S TM=""
    96         F  S TM=$O(^TMP("SCRATCH",$J,TM)) Q:TM=""  S TPNAME="" D
    97         .F  S TPNAME=$O(^TMP("SCRATCH",$J,TM,TPNAME)) Q:TPNAME=""  S EN="" D
    98         ..F  S EN=$O(^TMP("SCRATCH",$J,TM,TPNAME,EN)) Q:EN=""  D
    99         ...S NODE=^TMP("SCRATCH",$J,TM,TPNAME,EN)
    100         ...D KEEP^SCRPITP2(NODE,EN,TM)
    101         ...Q
    102         ..Q
    103         .Q
    104         Q
    105         ;
    106 PRINTIT(STORE,TITL)     ;
    107         N INST,EINST,ETEAM,TEM,NEW,PAGE,TNAME,TIEN,EN,SUB,POS,CIEN,INF,ACL
    108         S (INST,EINST)="",STOP=0,(PAGE,NEW)=1 W:$E(IOST)="C" @IOF
    109         D FORHEAD^SCRPITP2
    110         F  S EINST=$O(@STORE@("I",EINST)) Q:EINST=""!(STOP)  D
    111         .S INST=$O(@STORE@("I",EINST,""))
    112         .I INST="" Q
    113         .I STOP Q
    114         .;write team info
    115         .S TNAME=""
    116         .F  S TNAME=$O(@STORE@("T",INST,TNAME)) Q:TNAME=""!(STOP)  D
    117         ..D:NEW TITLE^SCRPU3(.PAGE,TITL,132)
    118         ..I 'NEW,$E(IOST)'="C" D NEWP1^SCRPU3(.PAGE,TITL,132)
    119         ..I 'NEW,$E(IOST)="C" D HOLD^SCRPU3(.PAGE,TITL,132)
    120         ..W !,$G(@STORE@(INST)),! S NEW=""
    121         ..S TIEN=$O(@STORE@("T",INST,TNAME,""))
    122         ..I TIEN="" Q
    123         ..F SUB="TI","D" D
    124         ...Q:STOP
    125         ...I '$D(@STORE@(INST,TIEN,SUB)) Q
    126         ...S EN=""
    127         ...F  S EN=$O(@STORE@(INST,TIEN,SUB,EN)) Q:EN=""!(STOP)  D
    128         ....I IOST'?1"C-".E,$Y>(IOSL-5) D NEWP1^SCRPU3(.PAGE,TITL,132)
    129         ....I IOST?1"C-".E,$Y>(IOSL-5) D HOLD^SCRPU3(.PAGE,TITL,132)
    130         ....I STOP Q
    131         ....I '$D(NEW) W !,$G(@STORE@(INST)),!,$G(@STORE@(INST,TIEN)),!
    132         ....W !,$G(@STORE@(INST,TIEN,SUB,EN))
    133         ...W !
    134         ..;write position info
    135         ..S POS=""
    136         ..I $Y<IOSL-10 D COLUMN^SCRPITP2
    137         ..F  S POS=$O(@STORE@(INST,TIEN,"P",POS)) Q:POS=""!(STOP)  D
    138         ...W !,$G(@STORE@(INST,TIEN,"P",POS))
    139         ...S ACL=""
    140         ...F  S ACL=$O(@STORE@(INST,TIEN,"P",POS,ACL)) Q:ACL=""!(STOP)  D
    141         ....W !,$G(@STORE@(INST,TIEN,"P",POS,ACL))
    142         ....I IOST'?1"C-".E,$Y>(IOSL-5) D NEWP1^SCRPU3(.PAGE,TITL,132) Q:STOP  D CONT^SCRPITP2
    143         ....I IOST?1"C-".E,$Y>(IOSL-5) D HOLD^SCRPU3(.PAGE,TITL,132) Q:STOP  D CONT^SCRPITP2
    144         ....I STOP Q
    145         ...;W !,$G(@STORE@(INST,TIEN,"P",POS))
    146         ...;W !,$G(@STORE@(INST,TIEN,"P",POS,ACL))
    147         ...W !
    148         I 'STOP,$E(IOST)="C" N DIR S DIR(0)="E" W ! D ^DIR
    149         Q
     1SCRPITP ;ALB/CMM - Individual Team Profile ; 29 Jun 99  04:11PM
     2 ;;5.3;Scheduling;**41,52,177**;AUG 13, 1993
     3 ;
     4 ;Individual Team Profile
     5 ;
     6PROMPTS ;
     7 ;Prompt for Institution, Team, and Print device
     8 ;
     9 N QTIME,PRNT,VAUTD,VAUTT,Y,NUMBER
     10 K VAUTD,VAUTT,SCUP
     11 S QTIME=""
     12 W ! D INST^SCRPU1 I Y=-1 G ERR
     13 W ! K Y D PRMTT^SCRPU1 I '$D(VAUTT) G ERR
     14 W !!,"This report requires 132 column output!"
     15 D QUE(.VAUTD,.VAUTT) Q
     16 ;
     17QUE(INST,TEAM) ;queue report
     18 ;Input Parameters:
     19 ;INST - institutions selected (variable and array)
     20 ;TEAM - teams selected (variable and array)
     21 N ZTSAVE,II
     22 F II="INST","TEAM","INST(","TEAM(" S ZTSAVE(II)=""
     23 W ! D EN^XUTMDEVQ("QENTRY^SCRPITP","Individual Team Profile",.ZTSAVE)
     24 Q
     25 ;
     26ENTRY2(INST,TEAM,IOP,ZTDTH) ;
     27 ;Second entry point for GUI to use
     28 ;Input Parameters:
     29 ;INST - institutions selected (variable and array)
     30 ;TEAM - teams selected (variable and array)
     31 ;IOP - print device
     32 ;ZTDTH - queue time (optional)
     33 ;
     34 ;validate parameters
     35 I '$D(INST)!'$D(TEAM)!'$D(IOP)!(IOP="") Q
     36 ;
     37 N NUMBER
     38 S IOST=$P(IOP,"^",2),IOP=$P(IOP,"^")
     39 I IOP?1"Q;".E S IOP=$P(IOP,"Q;",2)
     40 I IOST?1"C-".E D QENTRY G RET
     41 I ZTDTH="" S ZTDTH=$H
     42 S ZTRTN="QENTRY^SCRPITP"
     43 S ZTDESC="iIndividual Team Profile",ZTIO=IOP
     44 N II
     45 F II="INST","TEAM","INST(","TEAM(","IOP" S ZTSAVE(II)=""
     46 D ^%ZTLOAD
     47RET S NUMBER=0
     48 I $D(ZTSK) S NUMBER=ZTSK
     49 D EXIT1
     50 Q NUMBER
     51 ;
     52QENTRY ;
     53 ;driver entry point
     54 S TITL="Individual Team Profile"
     55 S STORE="^TMP("_$J_",""SCRPITP"")"
     56 K @STORE
     57 S @STORE=0
     58 I TEAM=1 D TALL^SCRPPAT3 S TEAM=0
     59 D FIND
     60 I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL)
     61 I '$D(NODATA) D PRINTIT(STORE,TITL)
     62 D EXIT2
     63 Q
     64 ;
     65ERR ;
     66EXIT1 ;
     67 K ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE
     68 Q
     69 ;
     70EXIT2 ;
     71 K @STORE
     72 K STOP,STORE,TITL,IOP,TEAM,INST,NODATA
     73 Q
     74 ;
     75FIND ;
     76 N TM,EN,NODE,TMP,TPNAME
     77 S TM="" K ^TMP("SCRATCH",$J)
     78 F  S TM=$O(^SCTM(404.57,"C",TM)) Q:TM=""  D
     79 .;$O through team position file
     80 .I '$D(TEAM(TM))&(TEAM'=1) Q
     81 .;Q above, not a selected team
     82 .;selected team
     83 .S EN=""
     84 .F  S EN=$O(^SCTM(404.57,"C",TM,EN)) Q:EN=""  D
     85 ..I '$D(^SCTM(404.57,EN,0)) Q
     86 ..S NODE=$G(^SCTM(404.57,EN,0))
     87 ..Q:NODE=""
     88 ..;active or inactive position
     89 ..S TMP=$$DATES^SCAPMCU1(404.59,EN,DT)
     90 ..S TPNAME=$P(NODE,U) S:'$L(TPNAME) TPNAME="~~~"
     91 ..S ^TMP("SCRATCH",$J,TPNAME,EN)=NODE
     92 ..I +TMP S ^TMP("SCRATCH",$J,TM,TPNAME,EN)=NODE
     93 ..Q
     94 .Q
     95 S TM=""
     96 F  S TM=$O(^TMP("SCRATCH",$J,TM)) Q:TM=""  S TPNAME="" D
     97 .F  S TPNAME=$O(^TMP("SCRATCH",$J,TM,TPNAME)) Q:TPNAME=""  S EN="" D
     98 ..F  S EN=$O(^TMP("SCRATCH",$J,TM,TPNAME,EN)) Q:EN=""  D
     99 ...S NODE=^TMP("SCRATCH",$J,TM,TPNAME,EN)
     100 ...D KEEP^SCRPITP2(NODE,EN,TM)
     101 ...Q
     102 ..Q
     103 .Q
     104 Q
     105 ;
     106PRINTIT(STORE,TITL) ;
     107 N INST,EINST,ETEAM,TEM,NEW,PAGE,TNAME,TIEN,EN,SUB,POS,CIEN,INF
     108 S (INST,EINST)="",STOP=0,(PAGE,NEW)=1 W:$E(IOST)="C" @IOF
     109 D FORHEAD^SCRPITP2
     110 F  S EINST=$O(@STORE@("I",EINST)) Q:EINST=""!(STOP)  D
     111 .S INST=$O(@STORE@("I",EINST,""))
     112 .I INST="" Q
     113 .I STOP Q
     114 .;write team info
     115 .S TNAME=""
     116 .F  S TNAME=$O(@STORE@("T",INST,TNAME)) Q:TNAME=""!(STOP)  D
     117 ..D:NEW TITLE^SCRPU3(.PAGE,TITL,132)
     118 ..I 'NEW,$E(IOST)'="C" D NEWP1^SCRPU3(.PAGE,TITL,132)
     119 ..I 'NEW,$E(IOST)="C" D HOLD^SCRPU3(.PAGE,TITL,132)
     120 ..W !,$G(@STORE@(INST)),! S NEW=""
     121 ..S TIEN=$O(@STORE@("T",INST,TNAME,""))
     122 ..I TIEN="" Q
     123 ..F SUB="TI","D" D
     124 ...Q:STOP
     125 ...I '$D(@STORE@(INST,TIEN,SUB)) Q
     126 ...S EN=""
     127 ...F  S EN=$O(@STORE@(INST,TIEN,SUB,EN)) Q:EN=""!(STOP)  D
     128 ....I IOST'?1"C-".E,$Y>(IOSL-5) D NEWP1^SCRPU3(.PAGE,TITL,132)
     129 ....I IOST?1"C-".E,$Y>(IOSL-5) D HOLD^SCRPU3(.PAGE,TITL,132)
     130 ....I STOP Q
     131 ....I '$D(NEW) W !,$G(@STORE@(INST)),!,$G(@STORE@(INST,TIEN)),!
     132 ....W !,$G(@STORE@(INST,TIEN,SUB,EN))
     133 ...W !
     134 ..;write position info
     135 ..S POS=""
     136 ..I $Y<IOSL-10 D COLUMN^SCRPITP2
     137 ..F  S POS=$O(@STORE@(INST,TIEN,"P",POS)) Q:POS=""!(STOP)  D
     138 ...I IOST'?1"C-".E,$Y>(IOSL-5) D NEWP1^SCRPU3(.PAGE,TITL,132) Q:STOP  D CONT^SCRPITP2
     139 ...I IOST?1"C-".E,$Y>(IOSL-5) D HOLD^SCRPU3(.PAGE,TITL,132) Q:STOP  D CONT^SCRPITP2
     140 ...I STOP Q
     141 ...W !,$G(@STORE@(INST,TIEN,"P",POS))
     142 ..W !
     143 I 'STOP,$E(IOST)="C" N DIR S DIR(0)="E" W ! D ^DIR
     144 Q

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPITP2.m

    r613 r623  
    1 SCRPITP2        ;ALB/CMM - Individual Team Profile Continued ;7/25/99  18:24
    2         ;;5.3;Scheduling;**41,177,520**;AUG 13, 1993;Build 26
    3         ;
    4         ;Individual Team Profile
    5         ;
    6 KEEP(TNODE,TPOS,TM,SCEN)        ;
    7         ;TNODE - zero node of the team position file entry TPOS
    8         ;TPOS - ien of team position file entry TNODE
    9         ;TM - ien of team
    10         ;
    11         N POS,PPC,CLIEN,PCLIN,MAX,ROL,CIEN,DIV
    12         N SCRDATE,SCI,PROVLIST,SCPROV,SCPTASS,ERR
    13         ;
    14         D TEAM(TM,.DIV)
    15         ;
    16         S POS=$P(TNODE,"^") ;position name
    17         S ROL=$P($G(^SD(403.46,+$P(TNODE,"^",3),0)),"^") ;standard position
    18         S PPC=$S($P(TNODE,"^",4)'=1:"NPC",+$$OKPREC3^SCMCLK(TPOS,DT)>0:" AP",1:"PCP") ;primary care position
    19         S MAX=$P(TNODE,"^",8)
    20         ;
    21         S SCRDATE="SCRDATE",(SCRDATE("BEGIN"),SCRDATE("END"))=DT,SCRDATE("INCL")=0
    22         S SCI="PROVLIST",SCI=$$PRTP^SCAPMC(TPOS,.SCRDATE,SCI,"ERR",1,0)
    23         S SCPROV=$P($G(PROVLIST(1)),U,2)
    24         S SCPTASS=$$PCPOSCNT^SCAPMCU1(TPOS,DT,0)
    25         ;
    26         ;D FORMAT(POS,PPC,MAX,DIV,TM,TPOS,ROL,SCPROV,SCPTASS)
    27         ;
    28         D SETASCL^SCRPRAC2(TPOS,.CNAME,.CLIEN)
    29         S CNAME=$G(CNAME(0))
    30         ;S CIEN=+$P(TNODE,"^",9) ;clinic ien ;USING MULTIPLE WITH SD*5.3*520
    31         ;S PCLIN=""
    32         ;I CIEN>0 S PCLIN=$P($G(^SC(CIEN,0)),"^") ;associated clinic
    33         ;
    34         D FORMAT(POS,PPC,MAX,DIV,TM,TPOS,ROL,CNAME,SCPROV,SCPTASS)
    35         N AC
    36         S AC=0
    37         F  S AC=$O(CNAME(AC)) Q:AC=""  D FORMATAC(POS,DIV,TM,TPOS,CNAME(AC))
    38         K CNAME
    39         Q
    40         ;
    41 TEAM(TM,DIV)    ;
    42         ;
    43         N TMN,TNAME,TDIV,TPHONE,TPC,TSERV,STAT,PUR,MAX,CUR
    44         S TMN=$G(^SCTM(404.51,TM,0)) ;zero node of team file
    45         S TNAME=$P(TMN,"^") ;team name
    46         S DIV=+$P(TMN,"^",7) ;division ien
    47         S TDIV=$P($G(^DIC(4,DIV,0)),"^") ;team division
    48         S TPHONE=$P(TMN,"^",2) ;team phone
    49         S TPC=+$P(TMN,"^",5) ;Primary Care Team ien
    50         S TSERV=$P($G(^DIC(49,+$P(TMN,"^",6),0)),"^") ;Service/section
    51         S STAT=$S(+$$ACTTM^SCMCTMU(TM)=1:"ACTIVE",1:"INACTIVE") ;Team status
    52         S PUR=$P($G(^SD(403.47,+$P(TMN,"^",3),0)),"^")
    53         S MAX=$P(TMN,"^",8)
    54         S CUR=$$TEAMCNT^SCAPMCU1(TM,DT)
    55         D TFORMAT(TNAME,DIV,TDIV,TM,TPHONE,TPC,TSERV,STAT,PUR,MAX,CUR)
    56         ;
    57         ;GET TEAM DESCRIPTION (WORD PROCESSING FIELD)
    58         D TDESC(TM,DIV)
    59         Q
    60 TDESC(TEM,DIV)  ;
    61         ;gets team description - word processing field
    62         Q:'$O(^SCTM(404.51,TEM,"D",0))
    63         N EN
    64         S EN=0
    65         S @STORE@(DIV,TEM,"D",0)="Team Description: "
    66         S @STORE@(DIV,TEM,"D",.5)=""
    67         F  S EN=$O(^SCTM(404.51,TEM,"D",EN)) Q:EN=""  D
    68         .S @STORE@(DIV,TEM,"D",EN)=$G(^SCTM(404.51,TEM,"D",EN,0))
    69         Q
    70         ;
    71 TFORMAT(TNAME,DIV,TDIV,TM,TPHONE,TPC,TSERV,STAT,PUR,MAX,CUR)    ;
    72         ;
    73         I TNAME="" S TNAME="[BAD DATA]"
    74         I TDIV="" S TDIV="[BAD DATA]"
    75         S @STORE@("I",TDIV,DIV)=""
    76         S @STORE@("T",DIV,TNAME,TM)=""
    77         S @STORE@(DIV)="Division: "_TDIV
    78         ;
    79         S @STORE@(DIV,TM,"TI",1)="Team Name: "_TNAME
    80         S $E(@STORE@(DIV,TM,"TI",1),44)="Service/Section: "_$E(TSERV,1,30)
    81         S $E(@STORE@(DIV,TM,"TI",1),(120-$L(TPHONE)))="Team Phone: "_TPHONE
    82         S @STORE@(DIV,TM,"TI",2)=""
    83         S @STORE@(DIV,TM,"TI",3)="Team Settings:"
    84         S @STORE@(DIV,TM,"TI",4)=""
    85         S @STORE@(DIV,TM,"TI",5)="Status: "_STAT
    86         S $E(@STORE@(DIV,TM,"TI",5),19)="Maximum Patients: "_MAX
    87         S $E(@STORE@(DIV,TM,"TI",5),47)="Unique Patients Assigned: "_CUR
    88         S $E(@STORE@(DIV,TM,"TI",5),83)="Purpose: "_$E(PUR,1,35)
    89         S @STORE@(DIV,TM,"TI",6)=""
    90         I CUR+1>MAX S @STORE@(DIV,TM,"TI",7)="This team is not accepting patients."
    91         I CUR<MAX,CUR'=MAX S @STORE@(DIV,TM,"TI",7)="This team is still accepting patients."
    92         Q
    93         ;
    94 FORMAT(POS,PPC,MAX,DIV,TM,TPOS,ROL,CNAME,SCPROV,SCPTASS)        ;
    95         ;
    96         I POS="" S POS="[BAD DATA]"
    97         S @STORE@(DIV,TM,"P",POS)=$E(POS,1,24) ;position
    98         S $E(@STORE@(DIV,TM,"P",POS),27)=$E(SCPROV,1,24) ;provider
    99         S $E(@STORE@(DIV,TM,"P",POS),53)=$E(ROL,1,24) ;standard role
    100         S $E(@STORE@(DIV,TM,"P",POS),77)=PPC ;primary care yes/no
    101         S $E(@STORE@(DIV,TM,"P",POS),82)=$J(MAX,6,0) ;number of patients allowed
    102         S $E(@STORE@(DIV,TM,"P",POS),92)=$J(SCPTASS,6,0) ;patients assigned
    103         S $E(@STORE@(DIV,TM,"P",POS),103)=$E(CNAME,1,30)
    104         Q
    105         ;
    106 FORMATAC(POS,DIV,TM,TPOS,CNAME) ;clinic name
    107         S $E(@STORE@(DIV,TM,"P",POS,AC),103)=$E(CNAME,1,30)
    108         Q
    109         ;
    110 FORHEAD ;
    111         S @STORE@("C",2)="Team Position"
    112         S $E(@STORE@("C",2),27)="Provider Name"
    113         S $E(@STORE@("C",2),53)="Standard Role"
    114         S $E(@STORE@("C",2),77)="PC?"
    115         S $E(@STORE@("C",1),82)="Patients"
    116         S $E(@STORE@("C",2),82)="Allowed"
    117         S $E(@STORE@("C",1),92)="Patients"
    118         S $E(@STORE@("C",2),92)="Assigned"
    119         S $E(@STORE@("C",2),103)="Associated Clinic"
    120         S $P(@STORE@("C",3),"=",133)=""
    121         Q
    122         ;
    123 CONT    ;Team continuation header
    124         W !,"Team '",TNAME,"' continued..."
    125 COLUMN  ;
    126         I STOP Q
    127         N EN
    128         S EN=0
    129         F  S EN=$O(@STORE@("C",EN)) Q:EN=""  D
    130         .W !,$G(@STORE@("C",EN))
    131         Q
    132         ;
     1SCRPITP2 ;ALB/CMM - Individual Team Profile Continued ;7/25/99  18:24
     2 ;;5.3;Scheduling;**41,177**;AUG 13, 1993
     3 ;
     4 ;Individual Team Profile
     5 ;
     6KEEP(TNODE,TPOS,TM,SCEN) ;
     7 ;TNODE - zero node of the team position file entry TPOS
     8 ;TPOS - ien of team position file entry TNODE
     9 ;TM - ien of team
     10 ;
     11 N POS,PPC,CLIEN,PCLIN,MAX,ROL,CIEN,DIV
     12 N SCRDATE,SCI,PROVLIST,SCPROV,SCPTASS,ERR
     13 ;
     14 D TEAM(TM,.DIV)
     15 ;
     16 S POS=$P(TNODE,"^") ;position name
     17 S ROL=$P($G(^SD(403.46,+$P(TNODE,"^",3),0)),"^") ;standard position
     18 S PPC=$S($P(TNODE,"^",4)'=1:"NPC",+$$OKPREC3^SCMCLK(TPOS,DT)>1:" AP",1:"PCP") ;primary care position
     19 S MAX=$P(TNODE,"^",8)
     20 ;
     21 S SCRDATE="SCRDATE",(SCRDATE("BEGIN"),SCRDATE("END"))=DT,SCRDATE("INCL")=0
     22 S SCI="PROVLIST",SCI=$$PRTP^SCAPMC(TPOS,.SCRDATE,SCI,"ERR",1,0)
     23 S SCPROV=$P($G(PROVLIST(1)),U,2)
     24 S SCPTASS=$$PCPOSCNT^SCAPMCU1(TPOS,DT,0)
     25 ;
     26 S CIEN=+$P(TNODE,"^",9) ;clinic ien
     27 S PCLIN=""
     28 I CIEN>0 S PCLIN=$P($G(^SC(CIEN,0)),"^") ;associated clinic
     29 ;
     30 D FORMAT(POS,PPC,MAX,DIV,TM,TPOS,ROL,PCLIN,SCPROV,SCPTASS)
     31 ;
     32 Q
     33 ;
     34TEAM(TM,DIV) ;
     35 ;
     36 N TMN,TNAME,TDIV,TPHONE,TPC,TSERV,STAT,PUR,MAX,CUR
     37 S TMN=$G(^SCTM(404.51,TM,0)) ;zero node of team file
     38 S TNAME=$P(TMN,"^") ;team name
     39 S DIV=+$P(TMN,"^",7) ;division ien
     40 S TDIV=$P($G(^DIC(4,DIV,0)),"^") ;team division
     41 S TPHONE=$P(TMN,"^",2) ;team phone
     42 S TPC=+$P(TMN,"^",5) ;Primary Care Team ien
     43 S TSERV=$P($G(^DIC(49,+$P(TMN,"^",6),0)),"^") ;Service/section
     44 S STAT=$S(+$$ACTTM^SCMCTMU(TM)=1:"ACTIVE",1:"INACTIVE") ;Team status
     45 S PUR=$P($G(^SD(403.47,+$P(TMN,"^",3),0)),"^")
     46 S MAX=$P(TMN,"^",8)
     47 S CUR=$$TEAMCNT^SCAPMCU1(TM,DT)
     48 D TFORMAT(TNAME,DIV,TDIV,TM,TPHONE,TPC,TSERV,STAT,PUR,MAX,CUR)
     49 ;
     50 ;GET TEAM DESCRIPTION (WORD PROCESSING FIELD)
     51 D TDESC(TM,DIV)
     52 Q
     53TDESC(TEM,DIV) ;
     54 ;gets team description - word processing field
     55 Q:'$O(^SCTM(404.51,TEM,"D",0))
     56 N EN
     57 S EN=0
     58 S @STORE@(DIV,TEM,"D",0)="Team Description: "
     59 S @STORE@(DIV,TEM,"D",.5)=""
     60 F  S EN=$O(^SCTM(404.51,TEM,"D",EN)) Q:EN=""  D
     61 .S @STORE@(DIV,TEM,"D",EN)=$G(^SCTM(404.51,TEM,"D",EN,0))
     62 Q
     63 ;
     64TFORMAT(TNAME,DIV,TDIV,TM,TPHONE,TPC,TSERV,STAT,PUR,MAX,CUR) ;
     65 ;
     66 I TNAME="" S TNAME="[BAD DATA]"
     67 I TDIV="" S TDIV="[BAD DATA]"
     68 S @STORE@("I",TDIV,DIV)=""
     69 S @STORE@("T",DIV,TNAME,TM)=""
     70 S @STORE@(DIV)="Division: "_TDIV
     71 ;
     72 S @STORE@(DIV,TM,"TI",1)="Team Name: "_TNAME
     73 S $E(@STORE@(DIV,TM,"TI",1),44)="Service/Section: "_$E(TSERV,1,30)
     74 S $E(@STORE@(DIV,TM,"TI",1),(120-$L(TPHONE)))="Team Phone: "_TPHONE
     75 S @STORE@(DIV,TM,"TI",2)=""
     76 S @STORE@(DIV,TM,"TI",3)="Team Settings:"
     77 S @STORE@(DIV,TM,"TI",4)=""
     78 S @STORE@(DIV,TM,"TI",5)="Status: "_STAT
     79 S $E(@STORE@(DIV,TM,"TI",5),19)="Maximum Patients: "_MAX
     80 S $E(@STORE@(DIV,TM,"TI",5),47)="Unique Patients Assigned: "_CUR
     81 S $E(@STORE@(DIV,TM,"TI",5),83)="Purpose: "_$E(PUR,1,35)
     82 S @STORE@(DIV,TM,"TI",6)=""
     83 I CUR+1>MAX S @STORE@(DIV,TM,"TI",7)="This team is not accepting patients."
     84 I CUR<MAX,CUR'=MAX S @STORE@(DIV,TM,"TI",7)="This team is still accepting patients."
     85 Q
     86 ;
     87FORMAT(POS,PPC,MAX,DIV,TM,TPOS,ROL,CNAME,SCPROV,SCPTASS) ;
     88 ;
     89 I POS="" S POS="[BAD DATA]"
     90 S @STORE@(DIV,TM,"P",POS)=$E(POS,1,24) ;position
     91 S $E(@STORE@(DIV,TM,"P",POS),27)=$E(SCPROV,1,24) ;provider
     92 S $E(@STORE@(DIV,TM,"P",POS),53)=$E(ROL,1,24) ;standard role
     93 S $E(@STORE@(DIV,TM,"P",POS),77)=PPC ;primary care yes/no
     94 S $E(@STORE@(DIV,TM,"P",POS),82)=$J(MAX,6,0) ;number of patients allowed
     95 S $E(@STORE@(DIV,TM,"P",POS),92)=$J(SCPTASS,6,0) ;patients assigned
     96 S $E(@STORE@(DIV,TM,"P",POS),103)=$E(CNAME,1,30) ;clinic name
     97 Q
     98 ;
     99FORHEAD ;
     100 S @STORE@("C",2)="Team Position"
     101 S $E(@STORE@("C",2),27)="Provider Name"
     102 S $E(@STORE@("C",2),53)="Standard Role"
     103 S $E(@STORE@("C",2),77)="PC?"
     104 S $E(@STORE@("C",1),82)="Patients"
     105 S $E(@STORE@("C",2),82)="Allowed"
     106 S $E(@STORE@("C",1),92)="Patients"
     107 S $E(@STORE@("C",2),92)="Assigned"
     108 S $E(@STORE@("C",2),103)="Associated Clinic"
     109 S $P(@STORE@("C",3),"=",133)=""
     110 Q
     111 ;
     112CONT ;Team continuation header
     113 W !,"Team '",TNAME,"' continued..."
     114COLUMN ;
     115 I STOP Q
     116 N EN
     117 S EN=0
     118 F  S EN=$O(@STORE@("C",EN)) Q:EN=""  D
     119 .W !,$G(@STORE@("C",EN))
     120 Q
     121 ;

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPPAT2.m

    r613 r623  
    1 SCRPPAT2        ;ALB/CMM - Practitioner's Patients ; 12/12/00 3:46pm
    2         ;;5.3;Scheduling;**41,48,174,181,177,231,433,297,526,520**;AUG 13, 1993;Build 26
    3         ;
    4         ;Listing of Practitioner's Patients
    5         ;
    6 DRIVE   ;
    7         ;driver module
    8         N PRAC,INF,ARRY,ERROR,NXT,OKAY,PIEN,TPRC
    9         S ARRY="^TMP(""SCARRAY"","_$J_")",ERROR="ERR"
    10         S TPRC="^TMP(""SCRP"",$J,""PRACT"")" M @TPRC=PRACT
    11         K @ARRY,@ERROR,PRACT
    12         I @TPRC=1 D ALL^SCRPPAT3 ;all practitioners selected
    13         S NXT=0
    14         F  S NXT=$O(@TPRC@(NXT)) Q:NXT=""!(NXT'?.N)  D
    15         .I @TPRC=0 S PIEN=NXT
    16         .I @TPRC=1 S PIEN=$P(@TPRC@(NXT),"^")
    17         .K @ARRY,@ERROR
    18         .S OKAY=$$PTPR^SCAPMC14(PIEN,"","","",ARRY,ERROR) ;patients for practitioner
    19         .I '+OKAY Q
    20         .D LOOPPT(ARRY,PIEN) ;loop through patients for practitioner
    21         K @ARRY,@ERROR,@TPRC
    22         K:SUMM @STORE@("PT")
    23         Q
    24         ;
    25 LOOPPT(ARY,PRAC)        ;loop through patients for practitioner
    26         ;ARY - array of patients for selected practitioner
    27         ;PRAC - practitioner ien
    28         N NXT,PIEN,TPIEN,PNAME,TPIEN,NODE,PTP,TPI,TPN,CLIEN,PTA,PTAN,TIEN
    29         N PC,TNODE,TNAME,PINF,POSN,PRCP,CNAME
    30         S NXT=0
    31         F  S NXT=$O(@ARY@(NXT)) Q:NXT=""!(NXT'?.N)  D
    32         .S NODE=$G(@ARY@(NXT))
    33         .Q:NODE=""
    34         .S PIEN=+$P(NODE,"^") ;ien of patient file entry
    35         .S TPIEN=+$P(NODE,"^",3) ;ien of patient team position assignment
    36         .S PTP=$G(^SCPT(404.43,TPIEN,0))
    37         .Q:PTP=""
    38         .S PTA=+$P(PTP,"^") ;patient team assignment ien (404.42)
    39         .S PTAN=$G(^SCPT(404.42,PTA,0))
    40         .Q:PTAN=""
    41         .S TIEN=+$P(PTAN,"^",3) ;team file ien (404.51)
    42         .I $G(TEAM)'=1,'$D(TEAM(TIEN)) Q  ;not a selected team
    43         .S TNODE=$G(^SCTM(404.51,TIEN,0))
    44         .Q:TNODE=""  I $G(INST)'=1,'$D(INST(+$P(TNODE,U,7))) Q
    45         .S TNAME=$P(TNODE,"^") ;team name
    46         .S TPI=+$P(PTP,"^",2) ;Team Position file ien (404.57)
    47         .S TPN=$G(^SCTM(404.57,TPI,0))
    48         .Q:TPN=""
    49         .I $G(ROLE)'=1,'$D(ROLE(+$P(TPN,U,3))) Q  ;not a selected role
    50         .S POSN=$P(TPN,"^") ;position name
    51         .D SETASCL^SCRPRAC2(TPI,.CNAME,.CLIEN)  ;get clinics from multiple
    52         .;S CLIEN=+$P(TPN,"^",9) ;associated clinic ien
    53         .;commented next line off - clinic enrollment no longer needed SD*5.3*433
    54         .;D CECHK(CLIEN,.CNAME,PIEN) ;is patient enrolled in associated clinic?
    55         .;S CNAME=$P($G(^SC(CLIEN,0)),"^")  ; SD*5.3*433 remove enroll check
    56         .S PC=$S($P(PTP,"^",5)=0:0,1:1) ;primary care position 1or2-yes/0-no
    57         .S PNAME=$P($G(^VA(200,+PRAC,0)),"^") ;practitioner name
    58         .Q:PNAME=""
    59         .S PRCP=$P($$OKPREC2^SCMCLK(TPI,DT),U,2)
    60         .D GETPINF(PIEN,.CLIEN,.PINF)  ;get patient information and appointments
    61         .S CNAME=$G(CNAME(0))  ;first line will capture position information
    62         .S PINF=$G(PINF(0))
    63         .I PINF=""  D
    64         ..S PINF=PIEN_"^"_$$PDATA^SCRPEC(PIEN,CNAME,CNAME,1)
    65         .D FORMAT(CNAME,PINF,PC,TIEN,TNAME,PRAC,PNAME,POSN,TPI,PRCP)
    66         .D SETFORM(PIEN,.CNAME,.PINF)
    67 SETFORM(PIEN,CNAME,PINF)         ;Format for clinic info only for multiples
    68         N SCCNT
    69         S SCCNT=0 F  S SCCNT=$O(PINF(SCCNT)) Q:SCCNT=""  D FORMATAC(CNAME(SCCNT),PINF(SCCNT),PC,TIEN,TNAME,PRAC,PNAME,POSN,TPI,PRCP)
    70         Q
    71 GETPINF(PIEN,CLIEN,PINF)         ;get patient info
    72         N SCCNT
    73         S SCCNT="" F  S SCCNT=$O(CLIEN(SCCNT)) Q:SCCNT=""  D
    74         .S PINF(SCCNT)=PIEN_"^"_$$PDATA^SCRPEC(PIEN,CLIEN(SCCNT),CNAME(SCCNT),1)
    75         Q
    76         ;
    77 CECHK(CLIEN,CNAME,PIEN) ;should no longer be used as of patch SD*5.3*433
    78         ;CLIEN - clinic ien
    79         ;CNAME - clinic name returned if patient is enrolled in clien clinic
    80         ;PIEN - patien ien
    81         ;
    82         N EN,NODE
    83         S CNAME=""
    84         I $D(^DPT(PIEN,"DE","B",CLIEN)) D
    85         .;enrolled at one time, check if discharged
    86         .S EN=$O(^DPT(PIEN,"DE","B",CLIEN,""))
    87         .S NODE=$G(^DPT(PIEN,"DE",EN,0))
    88         .Q:NODE=""
    89         .I $P(NODE,"^",3)="" S CNAME=$P($G(^SC(CLIEN,0)),"^") ;clinic name
    90         .I $P(NODE,"^",3)'="",$P(NODE,"^",3)>DT S CNAME=$P($G(^SC(CLIEN,0)),"^") ;clinic name
    91         Q
    92         ;
    93 FORMAT(CNAME,PINF,PC,TIEN,TNAME,PRAC,PNAME,POSN,TPI,PRCP)       ; format data for display
    94         ;CNAME - clinic name
    95         ;PINF - patient/clinic data
    96         ;PC - primary care 1/0
    97         ;TIEN - team file ien (#404.51)
    98         ;TNAME - team name
    99         ;PRAC - practitioner ien (#200)
    100         ;PNAME - practitioner name
    101         ;POSN - position name
    102         ;TPI - team position ien (#404.57)
    103         ;PRCP - preceptor name
    104         ;
    105         N IIEN,INAME,ERR
    106         S ERR=$$SETUP^SCRPPAT3(.IIEN,.INAME,TIEN,TNAME,PRAC,PNAME,POSN,TPI,PRCP)
    107         I ERR Q
    108         ;
    109         I SORT=1 D STOR(IIEN,TIEN,PRAC,PINF,PNAME,TNAME,TPI) ;sort division,team,practitioner
    110         I SORT=2 D STOR(IIEN,PRAC,TIEN,PINF,PNAME,TNAME,TPI) ;sort division,practitioner,team
    111         I SORT=3 D STOR(1,PRAC,1,PINF,PNAME,"T3",TPI)
    112         Q
    113         ;
    114 FORMATAC(CNAME,PINF,PC,TIEN,TNAME,PRAC,PNAME,POSN,TPI,PRCP)     ; format data for display
    115         ;CNAME - clinic name
    116         ;PINF - patient/clinic data
    117         ;PC - primary care 1/0
    118         ;TIEN - team file ien (#404.51)
    119         ;TNAME - team name
    120         ;PRAC - practitioner ien (#200)
    121         ;PNAME - practitioner name
    122         ;POSN - position name
    123         ;TPI - team position ien (#404.57)
    124         ;PRCP - preceptor name
    125         ;
    126         N IIEN,INAME,ERR
    127         S ERR=$$SETUP^SCRPPAT3(.IIEN,.INAME,TIEN,TNAME,PRAC,PNAME,POSN,TPI,PRCP)
    128         I ERR Q
    129         ;
    130         I SORT=1 D STORA(IIEN,TIEN,PRAC,PINF,PNAME,TNAME,TPI,SCCNT) ;sort division,team,practitioner
    131         I SORT=2 D STORA(IIEN,PRAC,TIEN,PINF,PNAME,TNAME,TPI,SCCNT) ;sort division,practitioner,team
    132         I SORT=3 D STORA(1,PRAC,1,PINF,PNAME,"T3",TPI,SCCNT)
    133         Q
    134         ;
    135 STOR(IIEN,SEC,TRD,PINF,PNAME,TNAME,TPI,SCCNT)   ;
    136         ;IIEN - ien institution
    137         ;SEC - second sort subscript, IEN team or IEN practitioner
    138         ;TRD - third sort subscript, IEN team or IEN practitioner
    139         ;PINF - patient/clinic info
    140         ;PNAME - practitioner name
    141         ;TNAME - team name
    142         ;TPI - team position ien
    143         ;
    144         N PIEN,PTNAME,PID
    145         S PIEN=+$P(PINF,"^") ;patient ien
    146         S PTNAME=$E($P(PINF,"^",2),1,10) ;patient name
    147         Q:$D(@STORE@("PT",IIEN,SEC,TRD,TPI,PTNAME,PIEN))
    148         S @STORE@("PT",IIEN,SEC,TRD,TPI,PTNAME,PIEN)=""
    149         I 'SUMM,'$D(@STORE@("PTOT",IIEN,SEC,TRD,PIEN)) D
    150         .;count each unique patient for any given practitioner for grand total
    151         .S @STORE@("PTOT",IIEN,SEC,TRD,PIEN)=""
    152         .S @STORE@("TOTAL",IIEN,PRAC,0)=$G(@STORE@("TOTAL",IIEN,PRAC,0))+1 ;patient count by practitioner
    153         ;
    154         S @STORE@("TOTAL",IIEN,PRAC,$S(SORT=3:1,1:TIEN),TPI)=$G(@STORE@("TOTAL",IIEN,PRAC,$S(SORT=3:1,1:TIEN),TPI))+1 ;patient count by practitioner and team
    155         Q:SUMM
    156         ;
    157         S @STORE@(IIEN,SEC,TRD,TPI,PIEN)=PTNAME
    158         S PID=$P(PINF,"^",3),PID=$TR(PID,"-","")
    159         S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),13)=PID ;ssn
    160         S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),25)=$P(PINF,"^",4) ;means test status
    161         S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),31)=$P(PINF,"^",5) ;eligibility
    162         ;Removed by patch 174
    163         ;S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),40)=$P(PINF,"^",6) ;patient status
    164         S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),42)=$P(PINF,"^",8) ;last appt
    165         S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),54)=$P(PINF,"^",9) ;nxt appt
    166         S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),66)=$E(CNAME,1,15) ;clinic
    167         Q
    168 STORA(IIEN,SEC,TRD,PINF,PNAME,TNAME,TPI,SCCNT)  ;
    169         I '$D(@STORE@(IIEN,SEC,TRD,TPI,PIEN,SCCNT))  D
    170         .S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN,SCCNT),42)=$P(PINF,"^",8) ;last appt
    171         .S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN,SCCNT),54)=$P(PINF,"^",9) ;nxt appt
    172         .S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN,SCCNT),66)=$E(CNAME,1,15) ;clinic
    173         .Q
    174         Q
     1SCRPPAT2 ;ALB/CMM - Practitioner's Patients ; 12/12/00 3:46pm
     2 ;;5.3;Scheduling;**41,48,174,181,177,231,433,297**;AUG 13, 1993
     3 ;
     4 ;Listing of Practitioner's Patients
     5 ;
     6DRIVE ;
     7 ;driver module
     8 N PRAC,INF,ARRY,ERROR,NXT,OKAY,PIEN,TPRC
     9 S ARRY="^TMP(""SCARRAY"","_$J_")",ERROR="ERR"
     10 S TPRC="^TMP(""SCRP"",$J,""PRACT"")" M @TPRC=PRACT
     11 K @ARRY,@ERROR,PRACT
     12 I @TPRC=1 D ALL^SCRPPAT3 ;all practitioners selected
     13 S NXT=0
     14 F  S NXT=$O(@TPRC@(NXT)) Q:NXT=""!(NXT'?.N)  D
     15 .I @TPRC=0 S PIEN=NXT
     16 .I @TPRC=1 S PIEN=$P(@TPRC@(NXT),"^")
     17 .K @ARRY,@ERROR
     18 .S OKAY=$$PTPR^SCAPMC14(PIEN,"","","",ARRY,ERROR) ;patients for practitioner
     19 .I '+OKAY Q
     20 .D LOOPPT(ARRY,PIEN) ;loop through patients for practitioner
     21 K @ARRY,@ERROR,@TPRC
     22 K:SUMM @STORE@("PT")
     23 Q
     24 ;
     25LOOPPT(ARY,PRAC) ;loop through patients for practitioner
     26 ;ARY - array of patients for selected practitioner
     27 ;PRAC - practitioner ien
     28 N NXT,PIEN,TPIEN,PNAME,TPIEN,NODE,PTP,TPI,TPN,CLIEN,CNAME,PTA,PTAN,TIEN
     29 N PC,TNODE,TNAME,PINF,POSN,PRCP
     30 S NXT=0
     31 F  S NXT=$O(@ARY@(NXT)) Q:NXT=""!(NXT'?.N)  D
     32 .S NODE=$G(@ARY@(NXT))
     33 .Q:NODE=""
     34 .S PIEN=+$P(NODE,"^") ;ien of patient file entry
     35 .S TPIEN=+$P(NODE,"^",3) ;ien of patient team position assignment
     36 .S PTP=$G(^SCPT(404.43,TPIEN,0))
     37 .Q:PTP=""
     38 .S PTA=+$P(PTP,"^") ;patient team assignment ien (404.42)
     39 .S PTAN=$G(^SCPT(404.42,PTA,0))
     40 .Q:PTAN=""
     41 .S TIEN=+$P(PTAN,"^",3) ;team file ien (404.51)
     42 .I $G(TEAM)'=1,'$D(TEAM(TIEN)) Q  ;not a selected team
     43 .S TNODE=$G(^SCTM(404.51,TIEN,0))
     44 .Q:TNODE=""  I $G(INST)'=1,'$D(INST(+$P(TNODE,U,7))) Q
     45 .S TNAME=$P(TNODE,"^") ;team name
     46 .S TPI=+$P(PTP,"^",2) ;Team Position file ien (404.57)
     47 .S TPN=$G(^SCTM(404.57,TPI,0))
     48 .Q:TPN=""
     49 .I $G(ROLE)'=1,'$D(ROLE(+$P(TPN,U,3))) Q  ;not a selected role
     50 .S POSN=$P(TPN,"^") ;position name
     51 .S CLIEN=+$P(TPN,"^",9) ;associated clinic ien
     52 .;commented next line off - clinic enrollment no longer needed SD*5.3*433
     53 .;D CECHK(CLIEN,.CNAME,PIEN) ;is patient enrolled in associated clinic?
     54 .S CNAME=$P($G(^SC(CLIEN,0)),"^")  ; SD*5.3*433 remove enroll check
     55 .S PC=$S($P(PTP,"^",5)=0:0,1:1) ;primary care position 1or2-yes/0-no
     56 .S PNAME=$P($G(^VA(200,+PRAC,0)),"^") ;practitioner name
     57 .Q:PNAME=""
     58 .S PRCP=$P($$OKPREC2^SCMCLK(TPI,DT),U,2)
     59 .S PINF=PIEN_"^"_$$PDATA^SCRPEC(PIEN,CLIEN,1)
     60 .;$$PDATA returns pt name,pid,mt,pelig,status,status date,last appt,nxt appt
     61 .D FORMAT(CNAME,PINF,PC,TIEN,TNAME,PRAC,PNAME,POSN,TPI,PRCP) ;formats data for display
     62 Q
     63 ;
     64CECHK(CLIEN,CNAME,PIEN) ;
     65 ;CLIEN - clinic ien
     66 ;CNAME - clinic name returned if patient is enrolled in clien clinic
     67 ;PIEN - patien ien
     68 ;
     69 N EN,NODE
     70 S CNAME=""
     71 I $D(^DPT(PIEN,"DE","B",CLIEN)) D
     72 .;enrolled at one time, check if discharged
     73 .S EN=$O(^DPT(PIEN,"DE","B",CLIEN,""))
     74 .S NODE=$G(^DPT(PIEN,"DE",EN,0))
     75 .Q:NODE=""
     76 .I $P(NODE,"^",3)="" S CNAME=$P($G(^SC(CLIEN,0)),"^") ;clinic name
     77 .I $P(NODE,"^",3)'="",$P(NODE,"^",3)>DT S CNAME=$P($G(^SC(CLIEN,0)),"^") ;clinic name
     78 Q
     79 ;
     80FORMAT(CNAME,PINF,PC,TIEN,TNAME,PRAC,PNAME,POSN,TPI,PRCP) ; format data for display
     81 ;CNAME - clinic name
     82 ;PINF - patient/clinic data
     83 ;PC - primary care 1/0
     84 ;TIEN - team file ien (#404.51)
     85 ;TNAME - team name
     86 ;PRAC - practitioner ien (#200)
     87 ;PNAME - practitioner name
     88 ;POSN - position name
     89 ;TPI - team position ien (#404.57)
     90 ;PRCP - preceptor name
     91 ;
     92 N IIEN,INAME,ERR
     93 S ERR=$$SETUP^SCRPPAT3(.IIEN,.INAME,TIEN,TNAME,PRAC,PNAME,POSN,TPI,PRCP)
     94 I ERR Q
     95 ;
     96 I SORT=1 D STOR(IIEN,TIEN,PRAC,PINF,PNAME,TNAME,TPI) ;sort division,team,practitioner
     97 I SORT=2 D STOR(IIEN,PRAC,TIEN,PINF,PNAME,TNAME,TPI) ;sort division,practitioner,team
     98 I SORT=3 D STOR(1,PRAC,1,PINF,PNAME,"T3",TPI)
     99 Q
     100 ;
     101STOR(IIEN,SEC,TRD,PINF,PNAME,TNAME,TPI) ;
     102 ;IIEN - ien institution
     103 ;SEC - second sort subscript, IEN team or IEN practitioner
     104 ;TRD - third sort subscript, IEN team or IEN practitioner
     105 ;PINF - patient/clinic info
     106 ;PNAME - practitioner name
     107 ;TNAME - team name
     108 ;TPI - team position ien
     109 ;
     110 N PIEN,PTNAME,PID
     111 S PIEN=+$P(PINF,"^") ;patient ien
     112 S PTNAME=$E($P(PINF,"^",2),1,15) ;patient name
     113 Q:$D(@STORE@("PT",IIEN,SEC,TRD,TPI,PTNAME,PIEN))
     114 S @STORE@("PT",IIEN,SEC,TRD,TPI,PTNAME,PIEN)=""
     115 ;
     116 I 'SUMM,'$D(@STORE@("PTOT",IIEN,SEC,TRD,PIEN)) D
     117 .;count each unique patient for any given practitioner for grand total
     118 .S @STORE@("PTOT",IIEN,SEC,TRD,PIEN)=""
     119 .S @STORE@("TOTAL",IIEN,PRAC,0)=$G(@STORE@("TOTAL",IIEN,PRAC,0))+1 ;patient count by practitioner
     120 ;
     121 S @STORE@("TOTAL",IIEN,PRAC,$S(SORT=3:1,1:TIEN),TPI)=$G(@STORE@("TOTAL",IIEN,PRAC,$S(SORT=3:1,1:TIEN),TPI))+1 ;patient count by practitioner and team
     122 Q:SUMM
     123 ;
     124 S @STORE@(IIEN,SEC,TRD,TPI,PIEN)=PTNAME
     125 S PID=$P(PINF,"^",3),PID=$TR(PID,"-","")
     126 S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),18)=$E(PID,6,10) ;last 4 pid - 5 places is for any pseudo
     127 S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),25)=$P(PINF,"^",4) ;means test status
     128 S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),31)=$P(PINF,"^",5) ;eligibility
     129 ;Removed by patch 174
     130 ;S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),40)=$P(PINF,"^",6) ;patient status
     131 S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),42)=$P(PINF,"^",8) ;last appt
     132 S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),54)=$P(PINF,"^",9) ;nxt appt
     133 S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),66)=$E(CNAME,1,15) ;clinic
     134 Q

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPPAT3.m

    r613 r623  
    1 SCRPPAT3        ;ALB/CMM - Practitioner's Patients ; 8/30/99 3:14pm
    2         ;;5.3;Scheduling;**41,52,148,174,181,177,297,526,520**;AUG 13, 1993;Build 26
    3         ;
    4         ;Listing of Practitioner's Patients
    5         ;
    6 PAT(INS,SEC,TRD,SEC3,ST3,ST4,POS)       ;
    7         ;writes patients for position/practitioner
    8         N PTN,PT,FIRST
    9         S PTN="",FIRST=1
    10         I SUMM D TOTAL1^SCRPPAT3(INS,SEC,TRD,POS) Q  ;Summary only
    11         F  S PTN=$O(@STORE@("PT",INS,SEC,TRD,POS,PTN)) Q:PTN=""!(STOP)  D
    12         .S PT=0
    13         .F  S PT=$O(@STORE@("PT",INS,SEC,TRD,POS,PTN,PT)) Q:'PT!(STOP)  D
    14         ..I FIRST D HEADER S FIRST=0
    15         ..W !,$G(@STORE@(INS,SEC,TRD,POS,PT)) ;print patient detail line
    16         ..;I FIRST D HEADER S FIRST=0
    17         ..N SCCN
    18         ..S SCCN=""
    19         ..F  S SCCN=$O(@STORE@(INS,SEC,TRD,POS,PT,SCCN)) Q:SCCN=""  D
    20         ...W !,$G(@STORE@(INS,SEC,TRD,POS,PT,SCCN)) ;print patient detail line
    21         ...I (IOST'?1"C-".E),$Y>(IOSL-5) S MORE=0 D NEWP1^SCRPU3(.PAGE,TITL) D:'STOP HEAD2(INS,SEC,TRD,SEC3,ST3,ST4,POS) D:(('FIRST&'STOP)!($G(SORT)=3)) HEADER
    22         ...I (IOST?1"C-".E),$Y>(IOSL-5) S MORE=0 D HOLD^SCRPU3(.PAGE,TITL) D:'STOP HEAD2(INS,SEC,TRD,SEC3,ST3,ST4,POS) D:'FIRST&'STOP HEADER
    23         ...Q:STOP
    24         ...;I FIRST D HEADER S FIRST=0
    25         ...Q
    26         ..Q
    27         .Q
    28         Q
    29         ;
    30 SPRINT(STORE,IOP,TITL,SORT)     ; Summary Print Only
    31         ;STORE - global location of data
    32         ;IOP - device to print to
    33         ;TITL - title of report
    34         ;SORT - sort order 1-div,team,pract/2-div,pract,team
    35         ;
    36         N PAGE
    37         S PAGE=1,STOP=0
    38         D OPEN^SCRPU3
    39         Q:$G(POP)
    40         D TITLE^SCRPU3(.PAGE,TITL)
    41         D CLOSE^SCRPU3
    42         Q
    43         ;
    44 TOTAL1(INS,SEC,TRD,POS) ;
    45         ;print team/practitioner total
    46         N TEM,PRC
    47         I SORT=1 S TEM=SEC,PRC=TRD
    48         I SORT=2!(SORT=3) S TEM=TRD,PRC=SEC
    49         W !!,$G(@STORE@("TH",INS,PRC,TEM,POS)),$G(@STORE@("TOTAL",INS,PRC,TEM,POS))
    50         Q
    51         ;
    52 HEAD2(INS,SEC,TRD,SEC3,ST3,ST4,POS)     ;
    53         I (SEC3="""TN""")&($D(@ST4@(INS,TRD,SEC))) D
    54         .W !,$G(@ST3@(INS,SEC)) ;write team (sort 1)
    55         .W !,$G(@STORE@(INS))
    56         .W !,$G(@ST4@(INS,TRD,SEC,POS)) ;write practitioner (sort 2)
    57         .I $L($G(@STORE@("PN",INS,TRD,SEC,POS,"PRCP"))) W !,@STORE@("PN",INS,TRD,SEC,POS,"PRCP")
    58         .W !
    59         I (SEC3="""PN""")&($D(@ST3@(INS,SEC,TRD))) D
    60         .W !,$G(@ST3@(INS,SEC,TRD,POS)) ;write practitioner (sort 1)
    61         .I $G(SORT)'=3 I $L($G(@STORE@("PN",INS,SEC,TRD,POS,"PRCP"))) W !,@STORE@("PN",INS,SEC,TRD,POS,"PRCP")
    62         .I $G(SORT)'=3 W !,$G(@ST4@(INS,TRD)) ;write team (sort 2)
    63         .W !,$G(@STORE@(INS))
    64         Q
    65         ;
    66 HEADER  ;
    67         Q:$G(MORE)
    68         I SORT=3 S MORE=1
    69         N NXT
    70         F NXT="H1","H2","H3" W !,$G(@STORE@(NXT))
    71         W !
    72         Q
    73         ;
    74 SHEAD   ;
    75         S @STORE@("H2")="Pt Name"
    76         S $E(@STORE@("H2"),15)="Pt ID"
    77         S $E(@STORE@("H1"),25)="M.T."
    78         S $E(@STORE@("H2"),25)="Stat"
    79         S $E(@STORE@("H1"),31)="Prim"
    80         S $E(@STORE@("H2"),31)="Elig"
    81         ;Removed by patch 174
    82         ;S $E(@STORE@("H1"),39)="Pat"
    83         ;S $E(@STORE@("H2"),39)="Stat"
    84         S $E(@STORE@("H1"),42)="Last"
    85         S $E(@STORE@("H2"),42)="Appt"
    86         S $E(@STORE@("H1"),54)="Next"
    87         S $E(@STORE@("H2"),54)="Appt"
    88         S $E(@STORE@("H2"),66)="Clinic"
    89         S $P(@STORE@("H3"),"=",81)=""
    90         Q
    91 ALL     ;
    92         ;get all practitioners for all teams selected
    93         I TEAM=1 D TALL ;all teams selected
    94         N TIEN,OKAY,XLIST,YLIST,SCTP,SCI,SCDT
    95         S TIEN=""
    96         F  S TIEN=$O(TEAM(TIEN)) Q:TIEN=""!(TIEN'?.N)  D
    97         .I $D(TEAM(TIEN)) D
    98         ..K XLIST
    99         ..S OKAY=$$TPTM^SCAPMC(TIEN,"","","","XLIST","ERROR")
    100         ..S SCTP=0 F  S SCTP=$O(XLIST("SCTP",TIEN,SCTP)) Q:'SCTP  D
    101         ...K YLIST S SCDT="SCDT",(SCDT("BEGIN"),SCDT("END"))=DT,SCDT("INCL")=0
    102         ...S OKAY=$$PRTP^SCAPMC(SCTP,.SCDT,"YLIST","ERROR",1,0)
    103         ...S SCI=0 F  S SCI=$O(YLIST(SCI)) Q:'SCI  D
    104         ....S @TPRC@(0)=$G(@TPRC@(0))+1
    105         ....S @TPRC@(@TPRC@(0))=YLIST(SCI)
    106         Q
    107         ;
    108 TALL    ;
    109         ;get all active team for divisions selected
    110         N NXT,IIEN,NODE
    111         S NXT=0,IIEN=""
    112         ;$O through team file and find all active teams for selected divisions
    113         F  S IIEN=$O(^SCTM(404.51,"AINST",IIEN)) Q:IIEN=""  D
    114         .I INST=1!$D(INST(IIEN)) D
    115         ..S TIEN=0
    116         ..F  S TIEN=$O(^SCTM(404.51,"AINST",IIEN,TIEN)) Q:TIEN=""  D
    117         ...I $$ACTTM^SCMCTMU(TIEN) S TEAM(TIEN)=""
    118         Q
    119         ;
    120 SETUP(IIEN,INAME,TIEN,TNAME,PRAC,PNAME,POSN,TPI,PRCP)   ;
    121         ;setup data
    122         S IIEN=+$P($G(^SCTM(404.51,TIEN,0)),"^",7) ;institution ien
    123         S INAME=$P($G(^DIC(4,IIEN,0)),"^") ;institution name
    124         I INAME="" S INAME="[BAD DATA]"
    125         ;
    126         I PNAME="" S PNAME="[BAD DATA]"
    127         I TNAME="" S TNAME="[BAD DATA]"
    128         I $G(SORT)=3 S IIEN=1,TIEN=1
    129         I '$D(@STORE@("PN",IIEN,PRAC,TIEN,TPI)) S @STORE@("PN",IIEN,PRAC,TIEN,TPI)="Practitioner: "_PNAME_$S(SORT=3:"",1:" ("_POSN_")")
    130         I $L(PRCP) S @STORE@("PN",IIEN,PRAC,TIEN,TPI,"PRCP")="   Preceptor: "_PRCP
    131         I '$D(@STORE@("TN",IIEN,$S($G(SORT)=3:1,1:TIEN))) S @STORE@("TN",IIEN,$S($G(SORT)=3:1,1:TIEN))="        Team: "_TNAME
    132         ;
    133         I '$D(@STORE@("I",$S($G(SORT)=3:"S3",1:INAME),IIEN)) S @STORE@("I",$S($G(SORT)=3:"S3",1:INAME),IIEN)="",@STORE@(IIEN)=$S(SORT=3:"",1:"    Division: "_INAME)
    134         S @STORE@("T",IIEN,$S($G(SORT)=3:"T3",1:TNAME),$S($G(SORT)=3:1,1:TIEN))=""
    135         I '$D(@STORE@("P",IIEN,PNAME,PRAC,TPI)) S @STORE@("P",IIEN,PNAME,PRAC,TPI)=""
    136         I '$D(@STORE@("TOTAL",IIEN,PRAC,0)) S @STORE@("TOTAL",IIEN,PRAC,0)=0
    137         I '$D(@STORE@("TOTAL",IIEN,PRAC,TIEN)) S @STORE@("TOTAL",IIEN,PRAC,TIEN)=0
    138         ;
    139         S @STORE@("TH",IIEN,PRAC)="Patient Count for "_PNAME_": "
    140         S @STORE@("TH",IIEN,PRAC,TIEN,TPI)="Patient Count for "_PNAME_": "
    141         N SCX
    142         S SCX=$E(PNAME,1,22),$E(SCX,25)=$E(POSN,1,22),$E(SCX,49)=$E(TNAME,1,22)
    143         S @STORE@("SUM0",IIEN,PRAC,TIEN,TPI)=SCX
    144         ;
    145         S @STORE@("TH",IIEN)="** Note: Patient Panel Count is a count of unique patients for each practitioner"
    146         Q 0
     1SCRPPAT3 ;ALB/CMM - Practitioner's Patients ; 8/30/99 3:14pm
     2 ;;5.3;Scheduling;**41,52,148,174,181,177,297**;AUG 13, 1993
     3 ;
     4 ;Listing of Practitioner's Patients
     5 ;
     6PAT(INS,SEC,TRD,SEC3,ST3,ST4,POS) ;
     7 ;writes patients for position/practitioner
     8 N PTN,PT,FIRST
     9 S PTN="",FIRST=1
     10 I SUMM D TOTAL1^SCRPPAT3(INS,SEC,TRD,POS) Q  ;Summary only
     11 F  S PTN=$O(@STORE@("PT",INS,SEC,TRD,POS,PTN)) Q:PTN=""!(STOP)  D
     12 .S PT=0
     13 .F  S PT=$O(@STORE@("PT",INS,SEC,TRD,POS,PTN,PT)) Q:'PT!(STOP)  D
     14 ..I (IOST'?1"C-".E),$Y>(IOSL-5) S MORE=0 D NEWP1^SCRPU3(.PAGE,TITL) D:'STOP HEAD2(INS,SEC,TRD,SEC3,ST3,ST4,POS) D:(('FIRST&'STOP)!($G(SORT)=3)) HEADER
     15 ..I (IOST?1"C-".E),$Y>(IOSL-5) S MORE=0 D HOLD^SCRPU3(.PAGE,TITL) D:'STOP HEAD2(INS,SEC,TRD,SEC3,ST3,ST4,POS) D:'FIRST&'STOP HEADER
     16 ..Q:STOP
     17 ..I FIRST D HEADER S FIRST=0
     18 ..W !,$G(@STORE@(INS,SEC,TRD,POS,PT)) ;print patient detail line
     19 ..Q
     20 .Q
     21 Q
     22 ;
     23SPRINT(STORE,IOP,TITL,SORT) ; Summary Print Only
     24 ;STORE - global location of data
     25 ;IOP - device to print to
     26 ;TITL - title of report
     27 ;SORT - sort order 1-div,team,pract/2-div,pract,team
     28 ;
     29 N PAGE
     30 S PAGE=1,STOP=0
     31 D OPEN^SCRPU3
     32 Q:$G(POP)
     33 D TITLE^SCRPU3(.PAGE,TITL)
     34 D CLOSE^SCRPU3
     35 Q
     36 ;
     37TOTAL1(INS,SEC,TRD,POS) ;
     38 ;print team/practitioner total
     39 N TEM,PRC
     40 I SORT=1 S TEM=SEC,PRC=TRD
     41 I SORT=2!(SORT=3) S TEM=TRD,PRC=SEC
     42 W !!,$G(@STORE@("TH",INS,PRC,TEM,POS)),$G(@STORE@("TOTAL",INS,PRC,TEM,POS))
     43 Q
     44 ;
     45HEAD2(INS,SEC,TRD,SEC3,ST3,ST4,POS) ;
     46 I (SEC3="""TN""")&($D(@ST4@(INS,TRD,SEC))) D
     47 .W !,$G(@ST3@(INS,SEC)) ;write team (sort 1)
     48 .W !,$G(@STORE@(INS))
     49 .W !,$G(@ST4@(INS,TRD,SEC,POS)) ;write practitioner (sort 2)
     50 .I $L($G(@STORE@("PN",INS,TRD,SEC,POS,"PRCP"))) W !,@STORE@("PN",INS,TRD,SEC,POS,"PRCP")
     51 .W !
     52 I (SEC3="""PN""")&($D(@ST3@(INS,SEC,TRD))) D
     53 .W !,$G(@ST3@(INS,SEC,TRD,POS)) ;write practitioner (sort 1)
     54 .I $G(SORT)'=3 I $L($G(@STORE@("PN",INS,SEC,TRD,POS,"PRCP"))) W !,@STORE@("PN",INS,SEC,TRD,POS,"PRCP")
     55 .I $G(SORT)'=3 W !,$G(@ST4@(INS,TRD)) ;write team (sort 2)
     56 .W !,$G(@STORE@(INS))
     57 Q
     58 ;
     59HEADER ;
     60 Q:$G(MORE)
     61 I SORT=3 S MORE=1
     62 N NXT
     63 F NXT="H1","H2","H3" W !,$G(@STORE@(NXT))
     64 W !
     65 Q
     66 ;
     67SHEAD ;
     68 S @STORE@("H2")="Pt Name"
     69 S $E(@STORE@("H2"),18)="Pt ID"
     70 S $E(@STORE@("H1"),25)="M.T."
     71 S $E(@STORE@("H2"),25)="Stat"
     72 S $E(@STORE@("H1"),31)="Prim"
     73 S $E(@STORE@("H2"),31)="Elig"
     74 ;Removed by patch 174
     75 ;S $E(@STORE@("H1"),39)="Pat"
     76 ;S $E(@STORE@("H2"),39)="Stat"
     77 S $E(@STORE@("H1"),42)="Last"
     78 S $E(@STORE@("H2"),42)="Appt"
     79 S $E(@STORE@("H1"),54)="Next"
     80 S $E(@STORE@("H2"),54)="Appt"
     81 S $E(@STORE@("H2"),66)="Clinic"
     82 S $P(@STORE@("H3"),"=",81)=""
     83 Q
     84ALL ;
     85 ;get all practitioners for all teams selected
     86 I TEAM=1 D TALL ;all teams selected
     87 N TIEN,OKAY,XLIST,YLIST,SCTP,SCI,SCDT
     88 S TIEN=""
     89 F  S TIEN=$O(TEAM(TIEN)) Q:TIEN=""!(TIEN'?.N)  D
     90 .I $D(TEAM(TIEN)) D
     91 ..K XLIST
     92 ..S OKAY=$$TPTM^SCAPMC(TIEN,"","","","XLIST","ERROR")
     93 ..S SCTP=0 F  S SCTP=$O(XLIST("SCTP",TIEN,SCTP)) Q:'SCTP  D
     94 ...K YLIST S SCDT="SCDT",(SCDT("BEGIN"),SCDT("END"))=DT,SCDT("INCL")=0
     95 ...S OKAY=$$PRTP^SCAPMC(SCTP,.SCDT,"YLIST","ERROR",1,0)
     96 ...S SCI=0 F  S SCI=$O(YLIST(SCI)) Q:'SCI  D
     97 ....S @TPRC@(0)=$G(@TPRC@(0))+1
     98 ....S @TPRC@(@TPRC@(0))=YLIST(SCI)
     99 Q
     100 ;
     101TALL ;
     102 ;get all active team for divisions selected
     103 N NXT,IIEN,NODE
     104 S NXT=0,IIEN=""
     105 ;$O through team file and find all active teams for selected divisions
     106 F  S IIEN=$O(^SCTM(404.51,"AINST",IIEN)) Q:IIEN=""  D
     107 .I INST=1!$D(INST(IIEN)) D
     108 ..S TIEN=0
     109 ..F  S TIEN=$O(^SCTM(404.51,"AINST",IIEN,TIEN)) Q:TIEN=""  D
     110 ...I $$ACTTM^SCMCTMU(TIEN) S TEAM(TIEN)=""
     111 Q
     112 ;
     113SETUP(IIEN,INAME,TIEN,TNAME,PRAC,PNAME,POSN,TPI,PRCP) ;
     114 ;setup data
     115 S IIEN=+$P($G(^SCTM(404.51,TIEN,0)),"^",7) ;institution ien
     116 S INAME=$P($G(^DIC(4,IIEN,0)),"^") ;institution name
     117 I INAME="" S INAME="[BAD DATA]"
     118 ;
     119 I PNAME="" S PNAME="[BAD DATA]"
     120 I TNAME="" S TNAME="[BAD DATA]"
     121 I $G(SORT)=3 S IIEN=1,TIEN=1
     122 I '$D(@STORE@("PN",IIEN,PRAC,TIEN,TPI)) S @STORE@("PN",IIEN,PRAC,TIEN,TPI)="Practitioner: "_PNAME_$S(SORT=3:"",1:" ("_POSN_")")
     123 I $L(PRCP) S @STORE@("PN",IIEN,PRAC,TIEN,TPI,"PRCP")="   Preceptor: "_PRCP
     124 I '$D(@STORE@("TN",IIEN,$S($G(SORT)=3:1,1:TIEN))) S @STORE@("TN",IIEN,$S($G(SORT)=3:1,1:TIEN))="        Team: "_TNAME
     125 ;
     126 I '$D(@STORE@("I",$S($G(SORT)=3:"S3",1:INAME),IIEN)) S @STORE@("I",$S($G(SORT)=3:"S3",1:INAME),IIEN)="",@STORE@(IIEN)=$S(SORT=3:"",1:"    Division: "_INAME)
     127 S @STORE@("T",IIEN,$S($G(SORT)=3:"T3",1:TNAME),$S($G(SORT)=3:1,1:TIEN))=""
     128 I '$D(@STORE@("P",IIEN,PNAME,PRAC,TPI)) S @STORE@("P",IIEN,PNAME,PRAC,TPI)=""
     129 I '$D(@STORE@("TOTAL",IIEN,PRAC,0)) S @STORE@("TOTAL",IIEN,PRAC,0)=0
     130 I '$D(@STORE@("TOTAL",IIEN,PRAC,TIEN)) S @STORE@("TOTAL",IIEN,PRAC,TIEN)=0
     131 ;
     132 S @STORE@("TH",IIEN,PRAC)="Patient Count for "_PNAME_": "
     133 S @STORE@("TH",IIEN,PRAC,TIEN,TPI)="Patient Count for "_PNAME_": "
     134 N SCX
     135 S SCX=$E(PNAME,1,22),$E(SCX,25)=$E(POSN,1,22),$E(SCX,49)=$E(TNAME,1,22)
     136 S @STORE@("SUM0",IIEN,PRAC,TIEN,TPI)=SCX
     137 ;
     138 S @STORE@("TH",IIEN)="** Note: Patient Panel Count is a count of unique patients for each practitioner"
     139 Q 0

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPRAC2.m

    r613 r623  
    1 SCRPRAC2        ;ALB/CMM - Practitioner Demographics continued ; 29 Jun 99  04:11PM
    2         ;;5.3;Scheduling;**41,177,520**;AUG 13, 1993;Build 26
    3         ;
    4         ;Practitioner Demographics Report
    5         ;
    6 GATHER(PARRAY,PRAC)     ;
    7         ;get practitioner data
    8         N ANODE,TIEN,PNAME,POS,STROL,USCL,TNAME,MAX,PHONE,ASSIGN,ROOM,SERV
    9         N NODE,PIEN,CNAME,PCLASS,PRCP,PRCPCNT,SCLN,SCI,NXT,PRCPCT,PRCPOS
    10         N PRCPTE,SCDT,SCRATCH
    11         S NXT=0
    12         F  S NXT=$O(@PARRAY@(NXT)) Q:NXT=""!(NXT'?.N)  D
    13         .S (PNAME,PHONE,SERV,ROOM)=""
    14         .D PINFO(PRAC,.PNAME,.PHONE,.ROOM,.SERV)
    15         .;get provider name, office phone, room, service/section, person class
    16         .;
    17         .S ANODE=$G(@PARRAY@(NXT))
    18         .Q:ANODE=""
    19         .S PIEN=+$P(ANODE,"^") ;position ien
    20         .;
    21         .;Get precepted provider information
    22         .S PRCPCNT=0
    23         .S SCDT="SCDT",(SCDT("BEGIN"),SCDT("END"))="DT",SCDT("INCL")=0
    24         .K ^TMP("SCRATCH",$J),^TMP("SCRATCH1",$J) S SCI="^TMP(""SCRATCH1"",$J)"
    25         .S SCI=$$PRECHIS^SCMCLK(PIEN,.SCDT,SCI),SCI=0
    26         .F  S SCI=$O(^TMP("SCRATCH1",$J,SCI)) Q:'SCI  D
    27         ..N SCPRCD,SCTP
    28         ..S SCPRCD=^TMP("SCRATCH1",$J,SCI),SCTP=$P(SCPRCD,U,3)
    29         ..S PRCPTE=$P(SCPRCD,U,2) S:'$L(PRCPTE) PRCPTE="[unknown]"
    30         ..S PRCPOS=$P($G(SCRATCH(1)),U,4)
    31         ..S PRCPCT=$$PCPOSCNT^SCAPMCU1(SCTP,DT,0)
    32         ..S PRCPCNT=PRCPCNT+PRCPCT
    33         ..S ^TMP("SCRATCH",$J,PRCPTE,SCTP)=PRCPOS_U_PRCPCT
    34         ..Q
    35         .;
    36         .S POS=$P(ANODE,"^",2) ;position name
    37         .S STROL=$P(ANODE,"^",8) ;standard role name
    38         .S USCL=$P(ANODE,"^",10) ;user class name
    39         .S NODE=$G(^SCTM(404.57,PIEN,0))
    40         .S MAX=$P(NODE,"^",8) ;max patient assignments to position
    41         .S ASSIGN=+$$PCPOSCNT^SCAPMCU1(PIEN,DT,0) ;assigned patients
    42         .N CNAME,SCCLIEN
    43         .D SETASCL(PIEN,.CNAME,.SCCLIEN) ;associated clinics
    44         .;
    45         .;Get preceptor
    46         .S PRCP=$P($$OKPREC2^SCMCLK(PIEN,DT),U,2)
    47         .;
    48         .S TIEN=+$P(ANODE,"^",3) ;team ien
    49         .S TNAME=$P($G(^SCTM(404.51,TIEN,0)),"^") ;team name
    50         .;
    51         .;Set array for output
    52         .S SCLN=0
    53         .D SET1("Name",PNAME),SET2("Serv./Sect.",SERV)
    54         .D SET1("Team",TNAME),SET2("Position",POS)
    55         .D SET1("Role",STROL),SET2("User Class",USCL)
    56         .D SET1("Room",ROOM),SET2("Pts. Allowed",MAX)
    57         .D SET1("Phone",PHONE),SET2("Pts. Assigned",ASSIGN)
    58         .I $L($G(PRCP)) D SET3(1,"Preceptor: "_PRCP)
    59         .D SET3(4,"Assoc. Clinic: ")
    60         .D SETCNAME(.CNAME)
    61         .I $L(PCLASS(1)) D
    62         ..D SET3(4,"Person"),SET3(5,"Class: "_PCLASS(1)) D
    63         ..I $L(PCLASS(2)) D SET3(15,PCLASS(2)) D
    64         ...I $L(PCLASS(3)) D SET3(18,PCLASS(3))
    65         ...Q
    66         ..Q
    67         .Q:'$D(^TMP("SCRATCH",$J))
    68         .D SET3(1,"")
    69         .D SET4("Precepted Provider","Precepted Position","Pts. Precepted")
    70         .S SCI="",$P(SCI,"-",31)="" D SET4(SCI,SCI,$E(SCI,1,14))
    71         .S PRCPTE="" F  S PRCPTE=$O(^TMP("SCRATCH",$J,PRCPTE)) Q:PRCPTE=""  D
    72         ..S SCTP=0 F  S SCTP=$O(^TMP("SCRATCH",$J,PRCPTE,SCTP)) Q:'SCTP  D
    73         ...S PRCPOS=^TMP("SCRATCH",$J,PRCPTE,SCTP)
    74         ...S PRCPCT=+$P(PRCPOS,U,2),PRCPOS=$P(PRCPOS,U)
    75         ...D SET4(PRCPTE,PRCPOS,PRCPCT_"  ")
    76         ...Q
    77         ..Q
    78         .D SET3(1,"") S SCI="  Total precepted patients: "_PRCPCNT
    79         .S $E(SCI,37)=$J(("Total assigned/precepted patients: "_(PRCPCNT+ASSIGN)),42)
    80         .D SET3(1,SCI)
    81         .K ^TMP("SCRATCH",$J),^TMP("SCRATCH1",$J)
    82         .Q
    83         Q
    84         ;
    85 SETASCL(PIEN,CNAME,SCCLIEN)     ;SET ASSOCIATED CLINICS
    86         N I,CNT1
    87         S CNT1=0,I=0
    88         F  S I=$O(^SCTM(404.57,PIEN,5,I)) Q:'I  D
    89         .S SCCLIEN(CNT1)=I,CNAME(CNT1)=$P($G(^SC(I,0)),U),CNT1=CNT1+1
    90         Q
    91 SET1(LABEL,VALUE)       ;Set output line
    92         S SCLN=SCLN+1
    93         S @STORE@(PNAME,PIEN,SCLN)=$J(LABEL,9)_": "_$E(VALUE,1,26)
    94         Q
    95         ;
    96 SET2(LABEL,VALUE)       ;Set second column of output line
    97         S $E(@STORE@(PNAME,PIEN,SCLN),40)=$J(LABEL,13)_": "_$E(VALUE,1,26)
    98         Q
    99         ;
    100 SET3(COL,VALUE) ;Set output line
    101         N SCX
    102         S SCLN=SCLN+1,SCX="",$E(SCX,COL)=$E(VALUE,1,(80-(COL-1)))
    103         S @STORE@(PNAME,PIEN,SCLN)=SCX
    104         Q
    105         ;
    106 SET4(V1,V2,V3)  ;Set output line
    107         S SCLN=SCLN+1,V1="  "_V1,$E(V1,35)=V2,$E(V1,67)=$J(V3,14)
    108         S @STORE@(PNAME,PIEN,SCLN)=V1
    109         Q
    110         ;
    111 SETCNAME(CNAME) ;associated clinics
    112         N A
    113         S A="" F  S A=$O(CNAME(A)) Q:A=""  D SET3(12,CNAME(A))
    114         Q
    115         ;
    116 PINFO(VAE,PRACT,OPH,ROOM,SERV)  ;
    117         ;practitioner information from new person file
    118         S PRACT=$P($G(^VA(200,VAE,0)),"^") ;practitioner name
    119         S OPH=$P($G(^VA(200,VAE,.13)),"^",2) ;office phone
    120         S ROOM=$P($G(^VA(200,VAE,.14)),"^") ;room
    121         S SERV=$P($G(^VA(200,VAE,5)),"^") ;service/section ien
    122         S SERV=$P($G(^DIC(49,+SERV,0)),"^") ;service/section name
    123         S PCLASS=$$GET^XUA4A72(VAE) ;Person class
    124         N SCI F SCI=1,2,3 S PCLASS(SCI)=$P(PCLASS,U,(SCI+1))
    125         Q
     1SCRPRAC2 ;ALB/CMM - Practitioner Demographics continued ; 29 Jun 99  04:11PM
     2 ;;5.3;Scheduling;**41,177**;AUG 13, 1993
     3 ;
     4 ;Practitioner Demographics Report
     5 ;
     6GATHER(PARRAY,PRAC) ;
     7 ;get practitioner data
     8 N ANODE,TIEN,PNAME,POS,STROL,USCL,TNAME,MAX,PHONE,ASSIGN,ROOM,SERV
     9 N NODE,PIEN,CNAME,PCLASS,PRCP,PRCPCNT,SCLN,SCI,NXT,PRCPCT,PRCPOS
     10 N PRCPTE,SCDT,SCRATCH
     11 S NXT=0
     12 F  S NXT=$O(@PARRAY@(NXT)) Q:NXT=""!(NXT'?.N)  D
     13 .S (PNAME,PHONE,SERV,ROOM)=""
     14 .D PINFO(PRAC,.PNAME,.PHONE,.ROOM,.SERV)
     15 .;get provider name, office phone, room, service/section, person class
     16 .;
     17 .S ANODE=$G(@PARRAY@(NXT))
     18 .Q:ANODE=""
     19 .S PIEN=+$P(ANODE,"^") ;position ien
     20 .;
     21 .;Get precepted provider information
     22 .S PRCPCNT=0
     23 .S SCDT="SCDT",(SCDT("BEGIN"),SCDT("END"))="DT",SCDT("INCL")=0
     24 .K ^TMP("SCRATCH",$J),^TMP("SCRATCH1",$J) S SCI="^TMP(""SCRATCH1"",$J)"
     25 .S SCI=$$PRECHIS^SCMCLK(PIEN,.SCDT,SCI),SCI=0
     26 .F  S SCI=$O(^TMP("SCRATCH1",$J,SCI)) Q:'SCI  D
     27 ..N SCPRCD,SCTP
     28 ..S SCPRCD=^TMP("SCRATCH1",$J,SCI),SCTP=$P(SCPRCD,U,3)
     29 ..S PRCPTE=$P(SCPRCD,U,2) S:'$L(PRCPTE) PRCPTE="[unknown]"
     30 ..S PRCPOS=$P($G(SCRATCH(1)),U,4)
     31 ..S PRCPCT=$$PCPOSCNT^SCAPMCU1(SCTP,DT,0)
     32 ..S PRCPCNT=PRCPCNT+PRCPCT
     33 ..S ^TMP("SCRATCH",$J,PRCPTE,SCTP)=PRCPOS_U_PRCPCT
     34 ..Q
     35 .;
     36 .S POS=$P(ANODE,"^",2) ;position name
     37 .S STROL=$P(ANODE,"^",8) ;standard role name
     38 .S USCL=$P(ANODE,"^",10) ;user class name
     39 .S NODE=$G(^SCTM(404.57,PIEN,0))
     40 .S MAX=$P(NODE,"^",8) ;max patient assignments to position
     41 .S ASSIGN=+$$PCPOSCNT^SCAPMCU1(PIEN,DT,0) ;assigned patients
     42 .S CNAME=$P($G(^SC(+$P(NODE,U,9),0)),U) ;associated clinic
     43 .;
     44 .;Get preceptor
     45 .S PRCP=$P($$OKPREC2^SCMCLK(PIEN,DT),U,2)
     46 .;
     47 .S TIEN=+$P(ANODE,"^",3) ;team ien
     48 .S TNAME=$P($G(^SCTM(404.51,TIEN,0)),"^") ;team name
     49 .;
     50 .;Set array for output
     51 .S SCLN=0
     52 .D SET1("Name",PNAME),SET2("Serv./Sect.",SERV)
     53 .D SET1("Team",TNAME),SET2("Position",POS)
     54 .D SET1("Role",STROL),SET2("User Class",USCL)
     55 .D SET1("Room",ROOM),SET2("Pts. Allowed",MAX)
     56 .D SET1("Phone",PHONE),SET2("Pts. Assigned",ASSIGN)
     57 .I $L($G(PRCP)) D SET3(1,"Preceptor: "_PRCP)
     58 .D SET3(4,"Assoc.")
     59 .D SET3(4,"Clinic: "_CNAME)
     60 .I $L(PCLASS(1)) D
     61 ..D SET3(4,"Person"),SET3(5,"Class: "_PCLASS(1)) D
     62 ..I $L(PCLASS(2)) D SET3(15,PCLASS(2)) D
     63 ...I $L(PCLASS(3)) D SET3(18,PCLASS(3))
     64 ...Q
     65 ..Q
     66 .Q:'$D(^TMP("SCRATCH",$J))
     67 .D SET3(1,"")
     68 .D SET4("Precepted Provider","Precepted Position","Pts. Precepted")
     69 .S SCI="",$P(SCI,"-",31)="" D SET4(SCI,SCI,$E(SCI,1,14))
     70 .S PRCPTE="" F  S PRCPTE=$O(^TMP("SCRATCH",$J,PRCPTE)) Q:PRCPTE=""  D
     71 ..S SCTP=0 F  S SCTP=$O(^TMP("SCRATCH",$J,PRCPTE,SCTP)) Q:'SCTP  D
     72 ...S PRCPOS=^TMP("SCRATCH",$J,PRCPTE,SCTP)
     73 ...S PRCPCT=+$P(PRCPOS,U,2),PRCPOS=$P(PRCPOS,U)
     74 ...D SET4(PRCPTE,PRCPOS,PRCPCT_"  ")
     75 ...Q
     76 ..Q
     77 .D SET3(1,"") S SCI="  Total precepted patients: "_PRCPCNT
     78 .S $E(SCI,37)=$J(("Total assigned/precepted patients: "_(PRCPCNT+ASSIGN)),42)
     79 .D SET3(1,SCI)
     80 .K ^TMP("SCRATCH",$J),^TMP("SCRATCH1",$J)
     81 .Q
     82 Q
     83 ;
     84SET1(LABEL,VALUE) ;Set output line
     85 S SCLN=SCLN+1
     86 S @STORE@(PNAME,PIEN,SCLN)=$J(LABEL,9)_": "_$E(VALUE,1,26)
     87 Q
     88 ;
     89SET2(LABEL,VALUE) ;Set second column of output line
     90 S $E(@STORE@(PNAME,PIEN,SCLN),40)=$J(LABEL,13)_": "_$E(VALUE,1,26)
     91 Q
     92 ;
     93SET3(COL,VALUE) ;Set output line
     94 N SCX
     95 S SCLN=SCLN+1,SCX="",$E(SCX,COL)=$E(VALUE,1,(80-(COL-1)))
     96 S @STORE@(PNAME,PIEN,SCLN)=SCX
     97 Q
     98 ;
     99SET4(V1,V2,V3) ;Set output line
     100 S SCLN=SCLN+1,V1="  "_V1,$E(V1,35)=V2,$E(V1,67)=$J(V3,14)
     101 S @STORE@(PNAME,PIEN,SCLN)=V1
     102 Q
     103 ;
     104PINFO(VAE,PRACT,OPH,ROOM,SERV) ;
     105 ;practitioner information form new person file
     106 S PRACT=$P($G(^VA(200,VAE,0)),"^") ;practitioner name
     107 S OPH=$P($G(^VA(200,VAE,.13)),"^",2) ;office phone
     108 S ROOM=$P($G(^VA(200,VAE,.14)),"^") ;room
     109 S SERV=$P($G(^VA(200,VAE,5)),"^") ;service/section ien
     110 S SERV=$P($G(^DIC(49,+SERV,0)),"^") ;service/section name
     111 S PCLASS=$$GET^XUA4A72(VAE) ;Person class
     112 N SCI F SCI=1,2,3 S PCLASS(SCI)=$P(PCLASS,U,(SCI+1))
     113 Q

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPSLT.m

    r613 r623  
    1 SCRPSLT ;ALB/CMM - Summary Listing of Teams ; 29 Jun 99  04:11PM
    2         ;;5.3;Scheduling;**41,52,177,231,520**;AUG 13, 1993;Build 26
    3         ;
    4         ;Summary Listing of Teams Report
    5         ;
    6 PROMPTS ;
    7         ;Prompt for Institution, Team, Role and Print device
    8         ;
    9         N VAUTD,VAUTT,VAUTR,QTIME,PRNT,NUMBER
    10         K VAUTD,VAUTT,VAUTR,SCUP
    11         S QTIME=""
    12         W ! D INST^SCRPU1 I Y=-1 G ERR
    13         W ! K Y D PRMTT^SCRPU1 I '$D(VAUTT) G ERR
    14         W ! K Y D ROLE^SCRPU1 I '$D(VAUTR) G ERR
    15         W !!,"This report requires 132 column output!"
    16         D QUE(.VAUTD,.VAUTT,.VAUTR) Q
    17         ;
    18 QUE(INST,TEAM,ROLE)     ;queue report
    19         ;Input Parameters:
    20         ;INST - institutions selected (variable and array)
    21         ;TEAM - teams selected (variable and array)
    22         ;ROLE - roles selected (variable and array)
    23         N ZTSAVE,II
    24         F II="INST","TEAM","ROLE","INST(","TEAM(","ROLE(" S ZTSAVE(II)=""
    25         W ! D EN^XUTMDEVQ("QENTRY^SCRPSLT","Summary Listing of Teams",.ZTSAVE)
    26         Q
    27         ;
    28 ENTRY2(INST,TEAM,ROLE,IOP,ZTDTH)        ;
    29         ;Second entry point for GUI to use
    30         ;Input Parameters:
    31         ;INST - institutions selected (variable and array)
    32         ;TEAM - teams selected (variable and array)
    33         ;ROLE - roles selected (variable and array)
    34         ;IOP - print device
    35         ;ZTDTH - queue time (optional)
    36         ;
    37         ;validate parameters
    38         I '$D(INST)!'$D(TEAM)!'$D(ROLE)!'$D(IOP)!(IOP="") Q
    39         ;
    40         N NUMBER
    41         S IOST=$P(IOP,"^",2),IOP=$P(IOP,"^")
    42         I IOP?1"Q;".E S IOP=$P(IOP,"Q;",2)
    43         I IOST?1"C-".E D QENTRY G RET
    44         I ZTDTH="" S ZTDTH=$H
    45         S ZTRTN="QENTRY^SCRPSLT"
    46         S ZTDESC="Summary Listing Of Teams",ZTIO=IOP
    47         N II
    48         F II="INST","TEAM","ROLE","INST(","TEAM(","ROLE(","IOP" S ZTSAVE(II)=""
    49         D ^%ZTLOAD
    50 RET     S NUMBER=0
    51         I $D(ZTSK) S NUMBER=ZTSK
    52         D EXIT1
    53         Q NUMBER
    54         ;
    55 QENTRY  ;
    56         ;driver entry point
    57         S TITL="Summary Listing of Teams"
    58         S STORE="^TMP("_$J_",""SCRPSLT"")"
    59         K @STORE
    60         S @STORE=0
    61         I TEAM=1 D TALL^SCRPPAT3 S TEAM=0
    62         D FIND
    63         I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL)
    64         I '$D(NODATA) D PRINTIT(STORE,TITL)
    65         D EXIT2
    66         Q
    67         ;
    68 ERR     ;
    69 EXIT1   ;
    70         K ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE,SCUP
    71         Q
    72         ;
    73 EXIT2   ;
    74         K @STORE
    75         K STOP,STORE,TITL,IOP,TEAM,INST,ROLE,NODATA
    76         Q
    77         ;
    78 FIND    ;
    79         N TM,EN2,EN,ROL,NODE,TEND,ACT,INA,TPASS,TPCN,TMAX,TMP,TOA,TNPC
    80         S TM=""
    81         F  S TM=$O(^SCTM(404.57,"C",TM)) Q:TM=""  D
    82         .;$O through team position file
    83         .I '$D(TEAM(TM))&(TEAM'=1) Q
    84         .;Q above, not a selected team
    85         .;selected team
    86         .S EN=""
    87         .S TPASS(TM)=0,TMAX(TM)=0,TPCN(TM)=0
    88         .F  S EN=$O(^SCTM(404.57,"C",TM,EN)) Q:EN=""  D
    89         ..I '$D(^SCTM(404.57,EN,0)) Q
    90         ..S NODE=$G(^SCTM(404.57,EN,0))
    91         ..Q:NODE=""
    92         ..S ROL=+$P(NODE,"^",3) ;role ien
    93         ..I '$D(ROLE(ROL))&(ROLE'=1) Q
    94         ..;Q above not a selected role
    95         ..;find active position during date range
    96         ..S TMP=$$DATES^SCAPMCU1(404.52,EN,DT)
    97         ..I +TMP=0 Q
    98         ..S EN2=+$P(TMP,"^",4)
    99         ..D KEEP^SCRPSLT2(NODE,EN,EN2,ROL,TM,.TPCN,.TNPC)
    100         ..S TPASS(TM)=$$TEAMCNT^SCAPMCU1(TM,DT)
    101         ..S TMAX(TM)=+$P($G(^SCTM(404.51,+TM,0)),U,8)
    102         ..S TOA(TM)=TMAX(TM)-TPASS(TM) S:TOA(TM)<0 TOA(TM)=0
    103         ..D TEAMT^SCRPSLT2(TM,.TPASS,.TMAX,.TPCN,.TOA,.TNPC)
    104         Q
    105         ;
    106 PRINTIT(STORE,TITL)     ;
    107         N INST,EINST,ETEAM,TEM,EPRACT,PRACT,NXT,PAGE,NPAGE,NEW,POS,SCAC
    108         S (INST,EINST)="",(NPAGE,STOP)=0,PAGE=1 W:$E(IOST)="C" @IOF
    109         D TITLE^SCRPU3(.PAGE,TITL)
    110         D FORHEAD^SCRPSLT2
    111         F  S EINST=$O(@STORE@("I",EINST)) Q:EINST=""!(STOP)  D
    112         .S INST=$O(@STORE@("I",EINST,""))
    113         .I INST="" Q
    114         .S (TEM,ETEAM)=""
    115         .F  S ETEAM=$O(@STORE@("T",INST,ETEAM)) Q:ETEAM=""!(STOP)  D
    116         ..S TEM=$O(@STORE@("T",INST,ETEAM,""))
    117         ..I TEM="" Q
    118         ..K NEW
    119         ..I NPAGE,(IOST'?1"C-".E) D NEWP^SCRPSLT2(INST,TEM,TITL,.PAGE) S NEW=""
    120         ..I NPAGE,(IOST?1"C-".E) D HOLD1^SCRPSLT2(.PAGE,TITL,INST,TEM) S NEW=""
    121         ..S NPAGE=1 I STOP Q
    122         ..I IOST'?1"C-".E,$Y>(IOSL-8) D NEWP^SCRPSLT2(INST,TEM,TITL,.PAGE) S NEW=""
    123         ..I IOST?1"C-".E,$Y>(IOSL-8) D HOLD1^SCRPSLT2(.PAGE,TITL,INST,TEM) S NEW=""
    124         ..I STOP Q
    125         ..I '$D(NEW) D HEADER^SCRPSLT2(INST,TEM)
    126         ..S (PRACT,EPRACT)=""
    127         ..F  S EPRACT=$O(@STORE@("PN",INST,TEM,EPRACT)) Q:EPRACT=""!(STOP)  D
    128         ...S PRACT=$O(@STORE@("PN",INST,TEM,EPRACT,""))
    129         ...I PRACT="" Q
    130         ...S POS=""
    131         ...F  S POS=$O(@STORE@(INST,TEM,PRACT,POS)) Q:POS=""!(STOP)  D
    132         ....W !,$G(@STORE@(INST,TEM,PRACT,POS))
    133         ....S SCAC=""
    134         ....F  S SCAC=$O(@STORE@(INST,TEM,PRACT,POS,SCAC)) Q:SCAC=""!(STOP)  D
    135         .....W !,$G(@STORE@(INST,TEM,PRACT,POS,SCAC))
    136         .....I IOST'?1"C-".E,$Y>(IOSL-4) D NEWP^SCRPSLT2(INST,TEM,TITL,.PAGE)
    137         .....I IOST?1"C-".E,$Y>(IOSL-4) D HOLD1^SCRPSLT2(.PAGE,TITL,INST,TEM)
    138         .....I STOP Q
    139         ....;W !,$G(@STORE@(INST,TEM,PRACT,POS)) ;writes info
    140         ..Q:STOP
    141         ..I IOST'?1"C-".E,$Y>(IOSL-8) D NEWP^SCRPSLT2(INST,TEM,TITL,.PAGE,1)
    142         ..I IOST?1"C-".E,$Y>(IOSL-8) D HOLD1^SCRPSLT2(.PAGE,TITL,INST,TEM,1)
    143         ..D TOTAL^SCRPSLT2(INST,TEM)
    144         .I STOP Q
    145         .S NPAGE=1
    146         I 'STOP,$E(IOST)="C" N DIR S DIR(0)="E" D ^DIR
    147         Q
     1SCRPSLT ;ALB/CMM - Summary Listing of Teams ; 29 Jun 99  04:11PM
     2 ;;5.3;Scheduling;**41,52,177,231**;AUG 13, 1993
     3 ;
     4 ;Summary Listing of Teams Report
     5 ;
     6PROMPTS ;
     7 ;Prompt for Institution, Team, Role and Print device
     8 ;
     9 N VAUTD,VAUTT,VAUTR,QTIME,PRNT,NUMBER
     10 K VAUTD,VAUTT,VAUTR,SCUP
     11 S QTIME=""
     12 W ! D INST^SCRPU1 I Y=-1 G ERR
     13 W ! K Y D PRMTT^SCRPU1 I '$D(VAUTT) G ERR
     14 W ! K Y D ROLE^SCRPU1 I '$D(VAUTR) G ERR
     15 W !!,"This report requires 132 column output!"
     16 D QUE(.VAUTD,.VAUTT,.VAUTR) Q
     17 ;
     18QUE(INST,TEAM,ROLE) ;queue report
     19 ;Input Parameters:
     20 ;INST - institutions selected (variable and array)
     21 ;TEAM - teams selected (variable and array)
     22 ;ROLE - roles selected (variable and array)
     23 N ZTSAVE,II
     24 F II="INST","TEAM","ROLE","INST(","TEAM(","ROLE(" S ZTSAVE(II)=""
     25 W ! D EN^XUTMDEVQ("QENTRY^SCRPSLT","Summary Listing of Teams",.ZTSAVE)
     26 Q
     27 ;
     28ENTRY2(INST,TEAM,ROLE,IOP,ZTDTH) ;
     29 ;Second entry point for GUI to use
     30 ;Input Parameters:
     31 ;INST - institutions selected (variable and array)
     32 ;TEAM - teams selected (variable and array)
     33 ;ROLE - roles selected (variable and array)
     34 ;IOP - print device
     35 ;ZTDTH - queue time (optional)
     36 ;
     37 ;validate parameters
     38 I '$D(INST)!'$D(TEAM)!'$D(ROLE)!'$D(IOP)!(IOP="") Q
     39 ;
     40 N NUMBER
     41 S IOST=$P(IOP,"^",2),IOP=$P(IOP,"^")
     42 I IOP?1"Q;".E S IOP=$P(IOP,"Q;",2)
     43 I IOST?1"C-".E D QENTRY G RET
     44 I ZTDTH="" S ZTDTH=$H
     45 S ZTRTN="QENTRY^SCRPSLT"
     46 S ZTDESC="Summary Listing Of Teams",ZTIO=IOP
     47 N II
     48 F II="INST","TEAM","ROLE","INST(","TEAM(","ROLE(","IOP" S ZTSAVE(II)=""
     49 D ^%ZTLOAD
     50RET S NUMBER=0
     51 I $D(ZTSK) S NUMBER=ZTSK
     52 D EXIT1
     53 Q NUMBER
     54 ;
     55QENTRY ;
     56 ;driver entry point
     57 S TITL="Summary Listing of Teams"
     58 S STORE="^TMP("_$J_",""SCRPSLT"")"
     59 K @STORE
     60 S @STORE=0
     61 I TEAM=1 D TALL^SCRPPAT3 S TEAM=0
     62 D FIND
     63 I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL)
     64 I '$D(NODATA) D PRINTIT(STORE,TITL)
     65 D EXIT2
     66 Q
     67 ;
     68ERR ;
     69EXIT1 ;
     70 K ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE,SCUP
     71 Q
     72 ;
     73EXIT2 ;
     74 K @STORE
     75 K STOP,STORE,TITL,IOP,TEAM,INST,ROLE,NODATA
     76 Q
     77 ;
     78FIND ;
     79 N TM,EN2,EN,ROL,NODE,TEND,ACT,INA,TPASS,TPCN,TMAX,TMP,TOA,TNPC
     80 S TM=""
     81 F  S TM=$O(^SCTM(404.57,"C",TM)) Q:TM=""  D
     82 .;$O through team position file
     83 .I '$D(TEAM(TM))&(TEAM'=1) Q
     84 .;Q above, not a selected team
     85 .;selected team
     86 .S EN=""
     87 .S TPASS(TM)=0,TMAX(TM)=0,TPCN(TM)=0
     88 .F  S EN=$O(^SCTM(404.57,"C",TM,EN)) Q:EN=""  D
     89 ..I '$D(^SCTM(404.57,EN,0)) Q
     90 ..S NODE=$G(^SCTM(404.57,EN,0))
     91 ..Q:NODE=""
     92 ..S ROL=+$P(NODE,"^",3) ;role ien
     93 ..I '$D(ROLE(ROL))&(ROLE'=1) Q
     94 ..;Q above not a selected role
     95 ..;find active position during date range
     96 ..S TMP=$$DATES^SCAPMCU1(404.52,EN,DT)
     97 ..I +TMP=0 Q
     98 ..S EN2=+$P(TMP,"^",4)
     99 ..D KEEP^SCRPSLT2(NODE,EN,EN2,ROL,TM,.TPCN,.TNPC)
     100 ..S TPASS(TM)=$$TEAMCNT^SCAPMCU1(TM,DT)
     101 ..S TMAX(TM)=+$P($G(^SCTM(404.51,+TM,0)),U,8)
     102 ..S TOA(TM)=TMAX(TM)-TPASS(TM) S:TOA(TM)<0 TOA(TM)=0
     103 ..D TEAMT^SCRPSLT2(TM,.TPASS,.TMAX,.TPCN,.TOA,.TNPC)
     104 Q
     105 ;
     106PRINTIT(STORE,TITL) ;
     107 N INST,EINST,ETEAM,TEM,EPRACT,PRACT,NXT,PAGE,NPAGE,NEW,POS
     108 S (INST,EINST)="",(NPAGE,STOP)=0,PAGE=1 W:$E(IOST)="C" @IOF
     109 D TITLE^SCRPU3(.PAGE,TITL)
     110 D FORHEAD^SCRPSLT2
     111 F  S EINST=$O(@STORE@("I",EINST)) Q:EINST=""!(STOP)  D
     112 .S INST=$O(@STORE@("I",EINST,""))
     113 .I INST="" Q
     114 .S (TEM,ETEAM)=""
     115 .F  S ETEAM=$O(@STORE@("T",INST,ETEAM)) Q:ETEAM=""!(STOP)  D
     116 ..S TEM=$O(@STORE@("T",INST,ETEAM,""))
     117 ..I TEM="" Q
     118 ..K NEW
     119 ..I NPAGE,(IOST'?1"C-".E) D NEWP^SCRPSLT2(INST,TEM,TITL,.PAGE) S NEW=""
     120 ..I NPAGE,(IOST?1"C-".E) D HOLD1^SCRPSLT2(.PAGE,TITL,INST,TEM) S NEW=""
     121 ..S NPAGE=1 I STOP Q
     122 ..I IOST'?1"C-".E,$Y>(IOSL-8) D NEWP^SCRPSLT2(INST,TEM,TITL,.PAGE) S NEW=""
     123 ..I IOST?1"C-".E,$Y>(IOSL-8) D HOLD1^SCRPSLT2(.PAGE,TITL,INST,TEM) S NEW=""
     124 ..I STOP Q
     125 ..I '$D(NEW) D HEADER^SCRPSLT2(INST,TEM)
     126 ..S (PRACT,EPRACT)=""
     127 ..F  S EPRACT=$O(@STORE@("PN",INST,TEM,EPRACT)) Q:EPRACT=""!(STOP)  D
     128 ...S PRACT=$O(@STORE@("PN",INST,TEM,EPRACT,""))
     129 ...I PRACT="" Q
     130 ...S POS=""
     131 ...F  S POS=$O(@STORE@(INST,TEM,PRACT,POS)) Q:POS=""!(STOP)  D
     132 ....I IOST'?1"C-".E,$Y>(IOSL-4) D NEWP^SCRPSLT2(INST,TEM,TITL,.PAGE)
     133 ....I IOST?1"C-".E,$Y>(IOSL-4) D HOLD1^SCRPSLT2(.PAGE,TITL,INST,TEM)
     134 ....I STOP Q
     135 ....W !,$G(@STORE@(INST,TEM,PRACT,POS)) ;writes info
     136 ..Q:STOP
     137 ..I IOST'?1"C-".E,$Y>(IOSL-8) D NEWP^SCRPSLT2(INST,TEM,TITL,.PAGE,1)
     138 ..I IOST?1"C-".E,$Y>(IOSL-8) D HOLD1^SCRPSLT2(.PAGE,TITL,INST,TEM,1)
     139 ..D TOTAL^SCRPSLT2(INST,TEM)
     140 .I STOP Q
     141 .S NPAGE=1
     142 I 'STOP,$E(IOST)="C" N DIR S DIR(0)="E" D ^DIR
     143 Q

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPSLT2.m

    r613 r623  
    1 SCRPSLT2        ;ALB/CMM - Summary Listing of Teams Continued ; 9/15/99 10:43am
    2         ;;5.3;Scheduling;**41,174,177,231,520**;AUG 13, 1993;Build 26
    3         ;
    4         ;Summary Listing of Teams Report
    5         ;
    6 KEEP(TNODE,APOS,TPOS,ROL,TM,TPCN,TNPC)  ;
    7         ;TNODE - zero node of the team position file
    8         ;APOS - ien of team position file
    9         ;TPOS - ien of position assignment history file
    10         ;ROL - ien of role
    11         ;TM - ien of team
    12         ;
    13         N POS,TNAME,TPHONE,TPC,TDIV,TEN,TMN,DIV,PPC,PCLIN,VAE,PRACT,NPC,MAX
    14         N PCN,ROLN,PRCTP,PRCPC,PRCNPC,PRCPTE,SCPC,SCNPC,XDAT,SCDT,SCI
    15         ;
    16         S TEN=+$P(TNODE,"^",2) ;team file pointer
    17         S TMN=$G(^SCTM(404.51,TEN,0))
    18         S TNAME=$P(TMN,"^") ;team name
    19         S DIV=+$P(TMN,"^",7) ;division ien
    20         S TDIV=$P($G(^DIC(4,DIV,0)),"^") ;team division
    21         D KTEAM(TNAME,TDIV,TM,DIV)
    22         ;
    23         S POS=$P(TNODE,"^") ;position name
    24         ;SD*5.3*231 - call SCMCLK to determine in AP or not
    25         S PPC=$S($P(TNODE,"^",4)<1:"NPC",+$$OKPREC3^SCMCLK(APOS,DT)>0:" AP",1:"PCP") ;PC?
    26         ;S PCLIN=$P($G(^SC(+$P(TNODE,"^",9),0)),"^") ;associated clinic
    27         D SETASCL^SCRPRAC2(APOS,.PCLIN)
    28         S PCLIN=$G(PCLIN(0))
    29         S ROLN=$P($G(^SD(403.46,+ROL,0)),U) ;role name
    30         ;
    31         S (PRCPC,PRCNPC)="",SCI="^TMP(""SCRATCH"",$J)"
    32         K @SCI
    33         S (SCDT("BEGIN"),SCDT("END"))=DT,SCDT("INCL")=0,SCDT="SCDT"
    34         S SCI=$$PRECHIS^SCMCLK(APOS,.SCDT,SCI)
    35         I SCI=1 S SCI=0 F  S SCI=$O(^TMP("SCRATCH",$J,SCI)) Q:'SCI  D
    36         .N SCPRCD
    37         .S SCPRCD=^TMP("SCRATCH",$J,SCI),PRCPTE=$P(SCPRCD,U,3) Q:'PRCPTE
    38         .S SCPC=$$PCPOSCNT^SCAPMCU1(PRCPTE,DT,1) ;precepted PC patients
    39         .S:SCPC<0 SCPC=0 S PRCPC=PRCPC+SCPC
    40         .S SCNPC=$$PCPOSCNT^SCAPMCU1(PRCPTE,DT,0) ;all precepted patients
    41         .S:SCNPC<0 SCNPC=0 S SCNPC=SCNPC-SCPC S:SCNPC<0 SCNPC=0
    42         .S PRCNPC=PRCNPC+SCNPC
    43         .Q
    44         ;
    45         S XDAT=ROLN_U_PRCPC_U_PRCNPC ;extra data
    46         ;
    47         S VAE=+$P($G(^SCTM(404.52,TPOS,0)),"^",3) ;ien of new person file
    48         S PRACT=$P($G(^VA(200,VAE,0)),"^") ;practitioner name
    49         I PRACT="" S PRACT="[Not Assigned]"
    50         ;
    51         S MAX=+$P(TNODE,"^",8) I MAX<0 S MAX=0
    52         S PCN=$$PCPOSCNT^SCAPMCU1(APOS,DT) S:PCN=-1 PCN=0
    53         S TPCN(TM)=$G(TPCN(TM))+PCN
    54         S NPC=$$PCPOSCNT^SCAPMCU1(APOS,DT,0) S:NPC=-1 NPC=0
    55         S NPC=NPC-PCN S:NPC<0 NPC=0
    56         S TNPC(TM)=$G(TNPC(TM))+NPC
    57         ;
    58         D FORMAT(APOS,POS,PCLIN,VAE,PRACT,PPC,DIV,TM,NPC,MAX,PCN,XDAT)
    59         N SCAC
    60         S SCAC=0
    61         F  S SCAC=$O(PCLIN(SCAC)) Q:SCAC=""  D FORMATAC(APOS,POS,PCLIN(SCAC),VAE,DIV,TM)
    62         Q
    63         ;
    64 TEAMT(TM,TPASS,TMAX,TPCN,TOA,TNPC)      ;
    65         ;set team totals into global
    66         S @STORE@("TOTALS",TM,"H1")="               Team Totals:"
    67         S @STORE@("TOTALS",TM,"H2")="------------------------------------"
    68         S @STORE@("TOTALS",TM,"H3")="  Primary Care Assignments: "_$J($G(TPCN(TM)),6,0)
    69         S @STORE@("TOTALS",TM,"H4")="        Non-PC Assignments: "_$J($G(TNPC(TM)),6,0)
    70         S @STORE@("TOTALS",TM,"H5")="  Unique Patients Assigned: "_$J($G(TPASS(TM)),6,0)
    71         S @STORE@("TOTALS",TM,"H6")="  Maximum Patients Allowed: "_$J($G(TMAX(TM)),6,0)
    72         S @STORE@("TOTALS",TM,"H7")="    Total Open Assignments: "_$J($G(TOA(TM)),6,0)
    73         Q
    74         ;
    75 FORMAT(APOS,POS,PCLIN,VAE,PRACT,PPC,DIV,TM,NPC,MX,PC,XDAT)      ;
    76         ;
    77         NEW TMP
    78         I PRACT="" S PRACT="Bad Data"
    79         S @STORE@("PN",DIV,TM,PRACT,VAE)=""
    80         S @STORE@(DIV,TM,VAE,APOS)=$E(PRACT,1,20) ;practitioner name
    81         S $E(@STORE@(DIV,TM,VAE,APOS),23)=$E(POS,1,20) ;position
    82         S $E(@STORE@(DIV,TM,VAE,APOS),45)=PPC ;PC?
    83         S $E(@STORE@(DIV,TM,VAE,APOS),50)=$E($P(XDAT,U),1,20) ;role
    84         S $E(@STORE@(DIV,TM,VAE,APOS),72)=$E(PCLIN,1,25) ;assoc. clinic
    85         S $E(@STORE@(DIV,TM,VAE,APOS),99)=$J(MX,6,0) ;max pts.
    86         S $E(@STORE@(DIV,TM,VAE,APOS),107)=$J(PC,5,0) ;PC pts.
    87         S $E(@STORE@(DIV,TM,VAE,APOS),114)=$J(NPC,5,0) ;non-PC pts.
    88         ;
    89         ;bp/djb 'Precepted Patients' column should be zero for APs.
    90         ;Old code begins
    91         ;S $E(@STORE@(DIV,TM,VAE,APOS),121)=$J($P(XDAT,U,2),5,0) ;precept PC
    92         ;S $E(@STORE@(DIV,TM,VAE,APOS),128)=$J($P(XDAT,U,3),5,0) ;precept NPC
    93         ;Old code ends
    94         ;New code begins
    95         S (TMP(1),TMP(2))=0 I PPC'["AP" D  ;APs should be zero
    96         .S TMP(1)=$P(XDAT,U,2)
    97         .S TMP(2)=$P(XDAT,U,3)
    98         S $E(@STORE@(DIV,TM,VAE,APOS),121)=$J(TMP(1),5,0) ;precepted PC
    99         S $E(@STORE@(DIV,TM,VAE,APOS),128)=$J(TMP(2),5,0) ;precepted NPC
    100         ;New code ends
    101         Q
    102 FORMATAC(APOS,POS,PCLIN,VAE,DIV,TM)     ;clinic multiples
    103         S $E(@STORE@(DIV,TM,VAE,APOS,SCAC),72)=$E(PCLIN,1,30)
    104         Q
    105         ;
    106 TOTAL(INST,TEM) ;
    107         ;Prints team totals
    108         N NXT
    109         S NXT=""
    110         W !
    111         F  S NXT=$O(@STORE@("TOTALS",TEM,NXT)) Q:NXT=""  D
    112         .;bp/djb Stop displaying certain 'Team Totals:' lines.
    113         .;New code begin
    114         .Q:$G(@STORE@("TOTALS",TEM,NXT))["Unique Patients Assigned"
    115         .Q:$G(@STORE@("TOTALS",TEM,NXT))["Maximum Patients Allowed"
    116         .Q:$G(@STORE@("TOTALS",TEM,NXT))["Total Open Assignments"
    117         .;New code end
    118         .W !,$G(@STORE@("TOTALS",TEM,NXT))
    119         W !
    120         Q
    121         ;
    122 KTEAM(TNAME,TDIV,TIEN,IEND)     ;
    123         ;store team information
    124         I TNAME="" S TNAME="[BAD DATA]"
    125         I TDIV="" S TDIV="[BAD DATA]"
    126         S @STORE@("I",TDIV,IEND)=""
    127         S @STORE@("T",IEND,TNAME,TIEN)=""
    128         S @STORE@(IEND)=" Division: "_TDIV
    129         S @STORE@(IEND,TIEN)="Team Name: "_TNAME
    130         Q
    131         ;
    132 FORHEAD ;
    133         S @STORE@("H3")="Practitioner"
    134         S $E(@STORE@("H3"),23)="Position"
    135         S $E(@STORE@("H3"),45)="PC?"
    136         S $E(@STORE@("H3"),50)="Standard Role"
    137         S $E(@STORE@("H3"),72)="Associated Clinic"
    138         S $E(@STORE@("H1"),101)="Max."
    139         S $E(@STORE@("H2"),101)="Pts."
    140         S $E(@STORE@("H3"),99)="Allow."
    141         S $E(@STORE@("H1"),107)="--Assigned--"
    142         S $E(@STORE@("H2"),107)="--Patients--"
    143         S $E(@STORE@("H3"),107)="PC     NonPC"
    144         S $E(@STORE@("H1"),121)="--Precepted-"
    145         S $E(@STORE@("H2"),121)="--Patients--"
    146         S $E(@STORE@("H3"),121)="PC     NonPC"
    147         S $P(@STORE@("H4"),"=",133)=""
    148         Q
    149 HEADER(INST,TEM,TEND)   ;
    150         N NXT
    151         S NXT="H",TEND=$G(TEND)
    152         W !!,@STORE@(INST)
    153         W !!,@STORE@(INST,TEM)
    154         I 'TEND F  S NXT=$O(@STORE@(NXT)) Q:NXT'?1"H".E  D
    155         .W !,@STORE@(NXT)
    156         W !
    157         Q
    158 NEWP(INST,TEM,TITL,PAGE,TEND)   ;
    159         S TEND=$G(TEND)
    160         D NEWP1^SCRPU3(.PAGE,TITL)
    161         I STOP Q
    162         D HEADER(INST,TEM,TEND)
    163         Q
    164 HOLD1(PAGE,TITL,INST,TEM,TEND)  ;
    165         ;device is home, reached end of page
    166         S TEND=$G(TEND)
    167         D HOLD^SCRPU3(.PAGE,TITL)
    168         I STOP Q
    169         D HEADER(INST,TEM,TEND)
    170         Q
     1SCRPSLT2 ;ALB/CMM - Summary Listing of Teams Continued ; 9/15/99 10:43am
     2 ;;5.3;Scheduling;**41,174,177,231**;AUG 13, 1993
     3 ;
     4 ;Summary Listing of Teams Report
     5 ;
     6KEEP(TNODE,APOS,TPOS,ROL,TM,TPCN,TNPC) ;
     7 ;TNODE - zero node of the team position file
     8 ;APOS - ien of team position file
     9 ;TPOS - ien of position assignment history file
     10 ;ROL - ien of role
     11 ;TM - ien of team
     12 ;
     13 N POS,TNAME,TPHONE,TPC,TDIV,TEN,TMN,DIV,PPC,PCLIN,VAE,PRACT,NPC,MAX
     14 N PCN,ROLN,PRCTP,PRCPC,PRCNPC,PRCPTE,SCPC,SCNPC,XDAT,SCDT,SCI
     15 ;
     16 S TEN=+$P(TNODE,"^",2) ;team file pointer
     17 S TMN=$G(^SCTM(404.51,TEN,0))
     18 S TNAME=$P(TMN,"^") ;team name
     19 S DIV=+$P(TMN,"^",7) ;division ien
     20 S TDIV=$P($G(^DIC(4,DIV,0)),"^") ;team division
     21 D KTEAM(TNAME,TDIV,TM,DIV)
     22 ;
     23 S POS=$P(TNODE,"^") ;position name
     24 ;SD*5.3*231 - call SCMCLK to determine in AP or not
     25 S PPC=$S($P(TNODE,"^",4)<1:"NPC",+$$OKPREC3^SCMCLK(APOS,DT)>1:" AP",1:"PCP") ;PC?
     26 S PCLIN=$P($G(^SC(+$P(TNODE,"^",9),0)),"^") ;associated clinic
     27 S ROLN=$P($G(^SD(403.46,+ROL,0)),U) ;role name
     28 ;
     29 S (PRCPC,PRCNPC)="",SCI="^TMP(""SCRATCH"",$J)"
     30 K @SCI
     31 S (SCDT("BEGIN"),SCDT("END"))=DT,SCDT("INCL")=0,SCDT="SCDT"
     32 S SCI=$$PRECHIS^SCMCLK(APOS,.SCDT,SCI)
     33 I SCI=1 S SCI=0 F  S SCI=$O(^TMP("SCRATCH",$J,SCI)) Q:'SCI  D
     34 .N SCPRCD
     35 .S SCPRCD=^TMP("SCRATCH",$J,SCI),PRCPTE=$P(SCPRCD,U,3) Q:'PRCPTE
     36 .S SCPC=$$PCPOSCNT^SCAPMCU1(PRCPTE,DT,1) ;precepted PC patients
     37 .S:SCPC<0 SCPC=0 S PRCPC=PRCPC+SCPC
     38 .S SCNPC=$$PCPOSCNT^SCAPMCU1(PRCPTE,DT,0) ;all precepted patients
     39 .S:SCNPC<0 SCNPC=0 S SCNPC=SCNPC-SCPC S:SCNPC<0 SCNPC=0
     40 .S PRCNPC=PRCNPC+SCNPC
     41 .Q
     42 ;
     43 S XDAT=ROLN_U_PRCPC_U_PRCNPC ;extra data
     44 ;
     45 S VAE=+$P($G(^SCTM(404.52,TPOS,0)),"^",3) ;ien of new person file
     46 S PRACT=$P($G(^VA(200,VAE,0)),"^") ;practitioner name
     47 I PRACT="" S PRACT="[Not Assigned]"
     48 ;
     49 S MAX=+$P(TNODE,"^",8) I MAX<0 S MAX=0
     50 S PCN=$$PCPOSCNT^SCAPMCU1(APOS,DT) S:PCN=-1 PCN=0
     51 S TPCN(TM)=$G(TPCN(TM))+PCN
     52 S NPC=$$PCPOSCNT^SCAPMCU1(APOS,DT,0) S:NPC=-1 NPC=0
     53 S NPC=NPC-PCN S:NPC<0 NPC=0
     54 S TNPC(TM)=$G(TNPC(TM))+NPC
     55 ;
     56 D FORMAT(APOS,POS,PCLIN,VAE,PRACT,PPC,DIV,TM,NPC,MAX,PCN,XDAT)
     57 Q
     58 ;
     59TEAMT(TM,TPASS,TMAX,TPCN,TOA,TNPC) ;
     60 ;set team totals into global
     61 S @STORE@("TOTALS",TM,"H1")="               Team Totals:"
     62 S @STORE@("TOTALS",TM,"H2")="------------------------------------"
     63 S @STORE@("TOTALS",TM,"H3")="  Primary Care Assignments: "_$J($G(TPCN(TM)),6,0)
     64 S @STORE@("TOTALS",TM,"H4")="        Non-PC Assignments: "_$J($G(TNPC(TM)),6,0)
     65 S @STORE@("TOTALS",TM,"H5")="  Unique Patients Assigned: "_$J($G(TPASS(TM)),6,0)
     66 S @STORE@("TOTALS",TM,"H6")="  Maximum Patients Allowed: "_$J($G(TMAX(TM)),6,0)
     67 S @STORE@("TOTALS",TM,"H7")="    Total Open Assignments: "_$J($G(TOA(TM)),6,0)
     68 Q
     69 ;
     70FORMAT(APOS,POS,PCLIN,VAE,PRACT,PPC,DIV,TM,NPC,MX,PC,XDAT) ;
     71 ;
     72 NEW TMP
     73 I PRACT="" S PRACT="Bad Data"
     74 S @STORE@("PN",DIV,TM,PRACT,VAE)=""
     75 S @STORE@(DIV,TM,VAE,APOS)=$E(PRACT,1,20) ;practitioner name
     76 S $E(@STORE@(DIV,TM,VAE,APOS),23)=$E(POS,1,20) ;position
     77 S $E(@STORE@(DIV,TM,VAE,APOS),45)=PPC ;PC?
     78 S $E(@STORE@(DIV,TM,VAE,APOS),50)=$E($P(XDAT,U),1,20) ;role
     79 S $E(@STORE@(DIV,TM,VAE,APOS),72)=$E(PCLIN,1,25) ;assoc. clinic
     80 S $E(@STORE@(DIV,TM,VAE,APOS),99)=$J(MX,6,0) ;max pts.
     81 S $E(@STORE@(DIV,TM,VAE,APOS),107)=$J(PC,5,0) ;PC pts.
     82 S $E(@STORE@(DIV,TM,VAE,APOS),114)=$J(NPC,5,0) ;non-PC pts.
     83 ;
     84 ;bp/djb 'Precepted Patients' column should be zero for APs.
     85 ;Old code begins
     86 ;S $E(@STORE@(DIV,TM,VAE,APOS),121)=$J($P(XDAT,U,2),5,0) ;precept PC
     87 ;S $E(@STORE@(DIV,TM,VAE,APOS),128)=$J($P(XDAT,U,3),5,0) ;precept NPC
     88 ;Old code ends
     89 ;New code begins
     90 S (TMP(1),TMP(2))=0 I PPC'["AP" D  ;APs should be zero
     91 .S TMP(1)=$P(XDAT,U,2)
     92 .S TMP(2)=$P(XDAT,U,3)
     93 S $E(@STORE@(DIV,TM,VAE,APOS),121)=$J(TMP(1),5,0) ;precepted PC
     94 S $E(@STORE@(DIV,TM,VAE,APOS),128)=$J(TMP(2),5,0) ;precepted NPC
     95 ;New code ends
     96 Q
     97 ;
     98TOTAL(INST,TEM) ;
     99 ;Prints team totals
     100 N NXT
     101 S NXT=""
     102 W !
     103 F  S NXT=$O(@STORE@("TOTALS",TEM,NXT)) Q:NXT=""  D
     104 .;bp/djb Stop displaying certain 'Team Totals:' lines.
     105 .;New code begin
     106 .Q:$G(@STORE@("TOTALS",TEM,NXT))["Unique Patients Assigned"
     107 .Q:$G(@STORE@("TOTALS",TEM,NXT))["Maximum Patients Allowed"
     108 .Q:$G(@STORE@("TOTALS",TEM,NXT))["Total Open Assignments"
     109 .;New code end
     110 .W !,$G(@STORE@("TOTALS",TEM,NXT))
     111 W !
     112 Q
     113 ;
     114KTEAM(TNAME,TDIV,TIEN,IEND) ;
     115 ;store team information
     116 I TNAME="" S TNAME="[BAD DATA]"
     117 I TDIV="" S TDIV="[BAD DATA]"
     118 S @STORE@("I",TDIV,IEND)=""
     119 S @STORE@("T",IEND,TNAME,TIEN)=""
     120 S @STORE@(IEND)=" Division: "_TDIV
     121 S @STORE@(IEND,TIEN)="Team Name: "_TNAME
     122 Q
     123 ;
     124FORHEAD ;
     125 S @STORE@("H3")="Practitioner"
     126 S $E(@STORE@("H3"),23)="Position"
     127 S $E(@STORE@("H3"),45)="PC?"
     128 S $E(@STORE@("H3"),50)="Standard Role"
     129 S $E(@STORE@("H3"),72)="Associated Clinic"
     130 S $E(@STORE@("H1"),101)="Max."
     131 S $E(@STORE@("H2"),101)="Pts."
     132 S $E(@STORE@("H3"),99)="Allow."
     133 S $E(@STORE@("H1"),107)="--Assigned--"
     134 S $E(@STORE@("H2"),107)="--Patients--"
     135 S $E(@STORE@("H3"),107)="PC     NonPC"
     136 S $E(@STORE@("H1"),121)="--Precepted-"
     137 S $E(@STORE@("H2"),121)="--Patients--"
     138 S $E(@STORE@("H3"),121)="PC     NonPC"
     139 S $P(@STORE@("H4"),"=",133)=""
     140 Q
     141HEADER(INST,TEM,TEND) ;
     142 N NXT
     143 S NXT="H",TEND=$G(TEND)
     144 W !!,@STORE@(INST)
     145 W !!,@STORE@(INST,TEM)
     146 I 'TEND F  S NXT=$O(@STORE@(NXT)) Q:NXT'?1"H".E  D
     147 .W !,@STORE@(NXT)
     148 W !
     149 Q
     150NEWP(INST,TEM,TITL,PAGE,TEND) ;
     151 S TEND=$G(TEND)
     152 D NEWP1^SCRPU3(.PAGE,TITL)
     153 I STOP Q
     154 D HEADER(INST,TEM,TEND)
     155 Q
     156HOLD1(PAGE,TITL,INST,TEM,TEND) ;
     157 ;device is home, reached end of page
     158 S TEND=$G(TEND)
     159 D HOLD^SCRPU3(.PAGE,TITL)
     160 I STOP Q
     161 D HEADER(INST,TEM,TEND)
     162 Q

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPTA.m

    r613 r623  
    1 SCRPTA  ;ALB/CMM - Patient Listing w/Team Assignment Data ; 29 Jun 99  04:11PM
    2         ;;5.3;Scheduling;**41,48,52,114,174,181,177,526**;AUG 13, 1993;Build 8
    3         ;
    4         ;Patient Listing w/Team Assignment Data Report
    5         ;
    6 PROMPTS ;
    7         ;Prompt for Institution, Team, Role, Practitioner and Print device
    8         ;
    9         N PRNT,QTIME,NUMBER
    10         K VAUTD,VAUTT,VAUTR,VAUTP,VAUTPP,SCUP
    11         S QTIME=""
    12         W ! D INST^SCRPU1 I Y=-1 G ERR
    13         W ! K Y D PRMTT^SCRPU1 I '$D(VAUTT) G ERR
    14         W ! K Y D ROLE^SCRPU1 I '$D(VAUTR) G ERR
    15         W ! K Y S VAUTPP="" D PRACT^SCRPU1 K VAUTPP I '$D(VAUTP) G ERR
    16         W !!,"This report requires 132 column output!"
    17         D QUE(.VAUTD,.VAUTT,.VAUTR,.VAUTP) Q
    18         ;
    19 QUE(INST,TEAM,ROLE,PRACT)       ;
    20         ;Input Parameters:
    21         ;INST - institutions selected (variable and array)
    22         ;TEAM - teams selected (variable and array)
    23         ;ROLE - roles selected (variable and array)
    24         ;PRACT - practitioners selected (variable and array)
    25         N ZTSAVE,II
    26         F II="INST","TEAM","ROLE","INST(","TEAM(","PRACT","PRACT(","ROLE(" S ZTSAVE(II)=""
    27         W ! D EN^XUTMDEVQ("QENTRY^SCRPTA","Patient Listing for Team Assignments",.ZTSAVE)
    28         Q
    29         ;
    30 ENTRY2(INST,TEAM,ROLE,PRACT,IOP,ZTDTH)  ;
    31         ;Second entry point for GUI to use
    32         ;Input Parameters:
    33         ;INST - institutions selected (variable and array)
    34         ;TEAM - teams selected (variable and array)
    35         ;ROLE - roles selected (variable and array)
    36         ;PRACT - practitioners selected (variable and array)
    37         ;IOP - print device
    38         ;ZTDTH - queue time (optional)
    39         ;
    40         ;validate parameters
    41         I '$D(INST)!'$D(TEAM)!'$D(ROLE)!'$D(PRACT)!'$D(IOP)!(IOP="") Q
    42         ;
    43         N NUMBER
    44         S IOST=$P(IOP,"^",2),IOP=$P(IOP,"^")
    45         I IOP?1"Q;".E S IOP=$P(IOP,"Q;",2)
    46         I IOST?1"C-".E D QENTRY G RET
    47         I ZTDTH="" S ZTDTH=$H
    48         S ZTRTN="QENTRY^SCRPTA"
    49         S ZTDESC="Patient Listing w/Team Assignment",ZTIO=IOP
    50         N II
    51         F II="INST","TEAM","ROLE","INST(","TEAM(","PRACT","PRACT(","ROLE(","IOP" S ZTSAVE(II)=""
    52         D ^%ZTLOAD
    53 RET     S NUMBER=0
    54         I $D(ZTSK) S NUMBER=ZTSK
    55         D EXIT1
    56         Q NUMBER
    57         ;
    58 QENTRY  ;
    59         ;driver entry point
    60         S TITL="Patient Listing For Team Assignments"
    61         S STORE="^TMP("_$J_",""SCRPTA"")"
    62         K @STORE
    63         S @STORE=0
    64         I TEAM=1 D TALL^SCRPPAT3 S TEAM=0
    65         D FIND
    66         I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL)
    67         I '$D(NODATA) D PRINTIT(STORE,TITL)
    68         D EXIT2
    69         Q
    70         ;
    71 ERR     ;
    72 EXIT1   ;
    73         K ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE,Y,SCUP
    74         Q
    75         ;
    76 EXIT2   ;
    77         K @STORE
    78         K STOP,STORE,TITL,IOP,TEAM,INST,ROLE,NODATA,PRACT
    79         Q
    80         ;
    81 FIND    ;
    82         N NXT,TLIST,TERR,CNT,ERR1,TNODE,NODE1,PIEN,PTAIEN
    83         S NXT=0,TLIST="^TMP("_$J_",""SCRPTA"",""LIST1"")",TERR="ERR1"
    84         K @TLIST,@TERR
    85         F  S NXT=$O(TEAM(NXT)) Q:NXT=""!(NXT'?.N)  D
    86         .S ERR1=$$PTTM^SCAPMC2(NXT,,.TLIST,.TERR) ;Patients assigned to team NXT
    87         .Q:ERR1=0
    88         .S CNT=0
    89         .F  S CNT=$O(@TLIST@(CNT)) Q:CNT=""!(CNT'?.N)  D
    90         ..S TNODE=$G(@TLIST@(CNT))
    91         ..Q:TNODE=""
    92         ..S PIEN=+$P(TNODE,"^") ;patient ien
    93         ..S PTAIEN=+$P(TNODE,"^",3) ;ien Patient Team Assignment #404.42
    94         ..D CHK^SCRPTA2(PTAIEN,PIEN)
    95         .K @TLIST,@TERR
    96         K @TLIST,@TERR
    97         Q
    98         ;
    99 PRINTIT(STORE,TITL)     ;
    100         N NXT,PAGE,NPAGE,INTN,TMN,INT,TM,PRN,PR,POS
    101         S (NPAGE,STOP,PAGE)=0,INTN="" W:$E(IOST)="C" @IOF
    102         D SHEAD ;setup headers
    103         F  S INTN=$O(@STORE@("I",INTN)) Q:INTN=""!(STOP)  D
    104         .S INT=$O(@STORE@("I",INTN,"")) ;institution
    105         .Q:INT=""
    106         .S TMN=""
    107         .F  S TMN=$O(@STORE@("T",INT,TMN)) Q:TMN=""!(STOP)  D
    108         ..S TM=$O(@STORE@("T",INT,TMN,"")) ;team
    109         ..Q:TM=""
    110         ..D NEWP1^SCRPU3(.PAGE,TITL,132) W !,$G(@STORE@(INT)),!!,$G(@STORE@(INT,TM))
    111         ..Q:STOP
    112         ..S PRN=""
    113         ..D HEADER
    114         ..F  S PRN=$O(@STORE@("P",INT,TM,PRN)) Q:PRN=""!(STOP)  D
    115         ...S PR=$O(@STORE@("P",INT,TM,PRN,"")) ;practitioner
    116         ...Q:PR=""
    117         ...S POS=""
    118         ...F  S POS=$O(@STORE@("P",INT,TM,PRN,PR,POS)) Q:POS=""!(STOP)  D
    119         ....D PRNT(INT,TM,PR,POS)
    120         I 'STOP,$E(IOST)="C" N DIR S DIR(0)="E" W ! D ^DIR
    121         Q
    122         ;
    123 PRNT(INT,TM,PR,POS)     ;
    124         ;INT - institution ien
    125         ;TM - team ien
    126         ;PR - practitioner ien
    127         ;POS - position ien
    128         ;
    129         N PTIEN,PTNAME
    130         S PTNAME=""
    131         F  S PTNAME=$O(@STORE@(INT,TM,PR,POS,PTNAME)) Q:PTNAME=""!(STOP)  D
    132         .S PTIEN=""
    133         .F  S PTIEN=$O(@STORE@(INT,TM,PR,POS,PTNAME,PTIEN)) Q:PTIEN=""!(STOP)  D
    134         ..I (IOST'?1"C-".E),$Y>(IOSL-4) D NEWP1^SCRPU3(.PAGE,TITL,132) W:'STOP !,$G(@STORE@(INT)),!!,$G(@STORE@(INT,TM)) D:'STOP HEADER
    135         ..I (IOST?1"C-".E),$Y>(IOSL-4) D HOLD^SCRPU3(.PAGE,TITL,132) W:'STOP !,$G(@STORE@(INT)),!!,$G(@STORE@(INT,TM)) D:'STOP HEADER
    136         ..Q:STOP
    137         ..W !,$G(@STORE@(INT,TM,PR,POS,PTNAME,PTIEN))
    138         .Q
    139         Q
    140         ;
    141 HEADER  ;
    142         ;write column headers
    143         N EN
    144         W !
    145         F EN="H1","H2","H3" D
    146         .W !,$G(@STORE@(EN))
    147         Q
    148 SHEAD   ;
    149         ;setup column headers
    150         S @STORE@("H2")="Patient Name"
    151         S $E(@STORE@("H2"),19)="Pt ID"
    152         S $E(@STORE@("H1"),31)="Date"
    153         S $E(@STORE@("H2"),31)="Assigned"
    154         S $E(@STORE@("H2"),43)="PC?"
    155         S $E(@STORE@("H2"),49)="Practitioner"
    156         S $E(@STORE@("H2"),70)="Position"
    157         S $E(@STORE@("H2"),92)="Standard Role"
    158         S $E(@STORE@("H2"),113)="Preceptor"
    159         S $P(@STORE@("H3"),"=",133)=""
    160         Q
     1SCRPTA ;ALB/CMM - Patient Listing w/Team Assignment Data ; 29 Jun 99  04:11PM
     2 ;;5.3;Scheduling;**41,48,52,114,174,181,177**;AUG 13, 1993
     3 ;
     4 ;Patient Listing w/Team Assignment Data Report
     5 ;
     6PROMPTS ;
     7 ;Prompt for Institution, Team, Role, Practitioner and Print device
     8 ;
     9 N PRNT,QTIME,NUMBER
     10 K VAUTD,VAUTT,VAUTR,VAUTP,VAUTPP,SCUP
     11 S QTIME=""
     12 W ! D INST^SCRPU1 I Y=-1 G ERR
     13 W ! K Y D PRMTT^SCRPU1 I '$D(VAUTT) G ERR
     14 W ! K Y D ROLE^SCRPU1 I '$D(VAUTR) G ERR
     15 W ! K Y S VAUTPP="" D PRACT^SCRPU1 K VAUTPP I '$D(VAUTP) G ERR
     16 W !!,"This report requires 132 column output!"
     17 D QUE(.VAUTD,.VAUTT,.VAUTR,.VAUTP) Q
     18 ;
     19QUE(INST,TEAM,ROLE,PRACT) ;
     20 ;Input Parameters:
     21 ;INST - institutions selected (variable and array)
     22 ;TEAM - teams selected (variable and array)
     23 ;ROLE - roles selected (variable and array)
     24 ;PRACT - practitioners selected (variable and array)
     25 N ZTSAVE,II
     26 F II="INST","TEAM","ROLE","INST(","TEAM(","PRACT","PRACT(","ROLE(" S ZTSAVE(II)=""
     27 W ! D EN^XUTMDEVQ("QENTRY^SCRPTA","Patient Listing for Team Assignments",.ZTSAVE)
     28 Q
     29 ;
     30ENTRY2(INST,TEAM,ROLE,PRACT,IOP,ZTDTH) ;
     31 ;Second entry point for GUI to use
     32 ;Input Parameters:
     33 ;INST - institutions selected (variable and array)
     34 ;TEAM - teams selected (variable and array)
     35 ;ROLE - roles selected (variable and array)
     36 ;PRACT - practitioners selected (variable and array)
     37 ;IOP - print device
     38 ;ZTDTH - queue time (optional)
     39 ;
     40 ;validate parameters
     41 I '$D(INST)!'$D(TEAM)!'$D(ROLE)!'$D(PRACT)!'$D(IOP)!(IOP="") Q
     42 ;
     43 N NUMBER
     44 S IOST=$P(IOP,"^",2),IOP=$P(IOP,"^")
     45 I IOP?1"Q;".E S IOP=$P(IOP,"Q;",2)
     46 I IOST?1"C-".E D QENTRY G RET
     47 I ZTDTH="" S ZTDTH=$H
     48 S ZTRTN="QENTRY^SCRPTA"
     49 S ZTDESC="Patient Listing w/Team Assignment",ZTIO=IOP
     50 N II
     51 F II="INST","TEAM","ROLE","INST(","TEAM(","PRACT","PRACT(","ROLE(","IOP" S ZTSAVE(II)=""
     52 D ^%ZTLOAD
     53RET S NUMBER=0
     54 I $D(ZTSK) S NUMBER=ZTSK
     55 D EXIT1
     56 Q NUMBER
     57 ;
     58QENTRY ;
     59 ;driver entry point
     60 S TITL="Patient Listing For Team Assignments"
     61 S STORE="^TMP("_$J_",""SCRPTA"")"
     62 K @STORE
     63 S @STORE=0
     64 I TEAM=1 D TALL^SCRPPAT3 S TEAM=0
     65 D FIND
     66 I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL)
     67 I '$D(NODATA) D PRINTIT(STORE,TITL)
     68 D EXIT2
     69 Q
     70 ;
     71ERR ;
     72EXIT1 ;
     73 K ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE,Y,SCUP
     74 Q
     75 ;
     76EXIT2 ;
     77 K @STORE
     78 K STOP,STORE,TITL,IOP,TEAM,INST,ROLE,NODATA,PRACT
     79 Q
     80 ;
     81FIND ;
     82 N NXT,TLIST,TERR,CNT,ERR1,TNODE,NODE1,PIEN,PTAIEN
     83 S NXT=0,TLIST="^TMP("_$J_",""SCRPTA"",""LIST1"")",TERR="ERR1"
     84 K @TLIST,@TERR
     85 F  S NXT=$O(TEAM(NXT)) Q:NXT=""!(NXT'?.N)  D
     86 .S ERR1=$$PTTM^SCAPMC2(NXT,,.TLIST,.TERR) ;Patients assigned to team NXT
     87 .Q:ERR1=0
     88 .S CNT=0
     89 .F  S CNT=$O(@TLIST@(CNT)) Q:CNT=""!(CNT'?.N)  D
     90 ..S TNODE=$G(@TLIST@(CNT))
     91 ..Q:TNODE=""
     92 ..S PIEN=+$P(TNODE,"^") ;patient ien
     93 ..S PTAIEN=+$P(TNODE,"^",3) ;ien Patient Team Assignment #404.42
     94 ..D CHK^SCRPTA2(PTAIEN,PIEN)
     95 .K @TLIST,@TERR
     96 K @TLIST,@TERR
     97 Q
     98 ;
     99PRINTIT(STORE,TITL) ;
     100 N NXT,PAGE,NPAGE,INTN,TMN,INT,TM,PRN,PR,POS
     101 S (NPAGE,STOP,PAGE)=0,INTN="" W:$E(IOST)="C" @IOF
     102 D SHEAD ;setup headers
     103 F  S INTN=$O(@STORE@("I",INTN)) Q:INTN=""!(STOP)  D
     104 .S INT=$O(@STORE@("I",INTN,"")) ;institution
     105 .Q:INT=""
     106 .S TMN=""
     107 .F  S TMN=$O(@STORE@("T",INT,TMN)) Q:TMN=""!(STOP)  D
     108 ..S TM=$O(@STORE@("T",INT,TMN,"")) ;team
     109 ..Q:TM=""
     110 ..D NEWP1^SCRPU3(.PAGE,TITL,132) W !,$G(@STORE@(INT)),!!,$G(@STORE@(INT,TM))
     111 ..Q:STOP
     112 ..S PRN=""
     113 ..D HEADER
     114 ..F  S PRN=$O(@STORE@("P",INT,TM,PRN)) Q:PRN=""!(STOP)  D
     115 ...S PR=$O(@STORE@("P",INT,TM,PRN,"")) ;practitioner
     116 ...Q:PR=""
     117 ...S POS=""
     118 ...F  S POS=$O(@STORE@("P",INT,TM,PRN,PR,POS)) Q:POS=""!(STOP)  D
     119 ....D PRNT(INT,TM,PR,POS)
     120 I 'STOP,$E(IOST)="C" N DIR S DIR(0)="E" W ! D ^DIR
     121 Q
     122 ;
     123PRNT(INT,TM,PR,POS) ;
     124 ;INT - institution ien
     125 ;TM - team ien
     126 ;PR - practitioner ien
     127 ;POS - position ien
     128 ;
     129 N PTIEN,PTNAME
     130 S PTNAME=""
     131 F  S PTNAME=$O(@STORE@(INT,TM,PR,POS,PTNAME)) Q:PTNAME=""!(STOP)  D
     132 .S PTIEN=""
     133 .F  S PTIEN=$O(@STORE@(INT,TM,PR,POS,PTNAME,PTIEN)) Q:PTIEN=""!(STOP)  D
     134 ..I (IOST'?1"C-".E),$Y>(IOSL-4) D NEWP1^SCRPU3(.PAGE,TITL,132) W:'STOP !,$G(@STORE@(INT)),!!,$G(@STORE@(INT,TM)) D:'STOP HEADER
     135 ..I (IOST?1"C-".E),$Y>(IOSL-4) D HOLD^SCRPU3(.PAGE,TITL,132) W:'STOP !,$G(@STORE@(INT)),!!,$G(@STORE@(INT,TM)) D:'STOP HEADER
     136 ..Q:STOP
     137 ..W !,$G(@STORE@(INT,TM,PR,POS,PTNAME,PTIEN))
     138 .Q
     139 Q
     140 ;
     141HEADER ;
     142 ;write column headers
     143 N EN
     144 W !
     145 F EN="H1","H2","H3" D
     146 .W !,$G(@STORE@(EN))
     147 Q
     148SHEAD ;
     149 ;setup column headers
     150 S @STORE@("H2")="Patient Name"
     151 S $E(@STORE@("H2"),24)="Pt ID"
     152 S $E(@STORE@("H1"),31)="Date"
     153 S $E(@STORE@("H2"),31)="Assigned"
     154 S $E(@STORE@("H2"),43)="PC?"
     155 S $E(@STORE@("H2"),49)="Practitioner"
     156 S $E(@STORE@("H2"),70)="Position"
     157 S $E(@STORE@("H2"),92)="Standard Role"
     158 S $E(@STORE@("H2"),113)="Preceptor"
     159 S $P(@STORE@("H3"),"=",133)=""
     160 Q

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPTA2.m

    r613 r623  
    1 SCRPTA2 ;ALB/CMM - Patient Listing w/Team Assignment Data ; 30 Jun 99  1:33 PM
    2         ;;5.3;Scheduling;**41,88,140,148,174,181,177,526**;AUG 13, 1993;Build 8
    3         ;
    4         ;Patient Listing w/Team Assignment Data Report continued
    5         ;
    6 CHK(PTIEN,PIEN) ;assigned to a position
    7         ;PTIEN - ien of 404.42 Patient Team Assignment file
    8         ;PIEN - ien of patient file #2
    9         ;
    10         N NODE,START,TPIEN,TPNODE,ROL,PRAC,ROLN,PCAP,PRCN
    11         S START=""
    12         Q:'$D(^SCPT(404.43,"B",PTIEN))&(PRACT'="")
    13         I '$D(^SCPT(404.43,"B",PTIEN))&(PRACT="") D NOTA(PTIEN,PIEN) Q
    14         F  S START=$O(^SCPT(404.43,"B",PTIEN,START)) Q:START=""  D
    15         .S NODE=$G(^SCPT(404.43,START,0))
    16         .Q:NODE=""
    17         .Q:($P(NODE,"^",4)'="")&($P(NODE,"^",4)<DT)
    18         .; ^ not assigned currently
    19         .S PCAP=+$P(NODE,U,5)
    20         .S TPIEN=+$P(NODE,"^",2) ;team position ien (404.57)
    21         .I '$D(^SCTM(404.57,TPIEN,0)) D NOTA(PTIEN,PIEN) Q
    22         .S TPNODE=$G(^SCTM(404.57,TPIEN,0))
    23         .I TPNODE="" D NOTA(PTIEN,PIEN) Q
    24         .S PCAP=$S('PCAP:"NPC",+$$OKPREC3^SCMCLK(TPIEN,DT)>0:" AP",1:"PCP") ; PC?
    25         .S PRCN=$P($$OKPREC2^SCMCLK(TPIEN,DT),U,2)  ;preceptor name
    26         .;
    27         .S ROL=+$P(TPNODE,"^",3) ;role for position (ien)
    28         .Q:'$D(ROLE(ROL))&(ROLE'=1)  ;not a selected role
    29         .S ROLN=$P($G(^SD(403.46,ROL,0)),U) ;role name
    30         .;
    31         .S PRAC=$$PRACI(TPIEN) ;practitioner information
    32         .I +PRAC=-1 D NOTA(PTIEN,PIEN) Q
    33         .I (PRACT'=1)&('$D(PRACT(+PRAC)))&(+PRAC'=0) Q
    34         .; ^ not a selected practitioner
    35         .;
    36         .S POS=$P($G(^SCTM(404.57,TPIEN,0)),"^")
    37         .D FOUND2(START,NODE,TPIEN,POS,TPNODE,PRAC,PIEN,ROLN,PCAP,PRCN)
    38         Q
    39 PRACI(TPIEN)    ;
    40         ;TPIEN - team position ien (404.57)
    41         ;
    42         N EN,TPLIST,TPERR,NAME,POS,ERR,NPIEN,NODE,POSIEN
    43         S TPLIST="TPLST",TPERR="ERR2"
    44         K @TPLIST,@TPERR
    45         S ERR=$$PRTP^SCAPMC8(TPIEN,,.TPLIST,.TPERR)
    46         Q:ERR=0!($D(@TPERR)) -1
    47         S NODE=$G(@TPLIST@(1))
    48         Q:NODE="" "0^[Not Assigned]"
    49         S NAME=$P(NODE,"^",2) ;practitioner name
    50         S NPIEN=+$P(NODE,"^") ;practitioner ien
    51         S POS=$P(NODE,"^",4) ;position name
    52         S POSIEN=+$P(NODE,"^",3) ;position ien
    53         I POS="" S POS="[Not Assigned]",POSIEN=0
    54         I NAME="" S NAME="[Not Assigned]",NPIEN=0
    55         K @TPLIST,@TPERR
    56         Q NPIEN_"^"_NAME_"^"_POS_"^"_POSIEN
    57         ;
    58 FOUND2(START,NODE,TPIEN,POS,TPNODE,PRAC,PIEN,ROLN,PCAP,PRCN)    ;
    59         ;START - patient team assignment position ien
    60         ;NODE - patient team position assignment node
    61         ;TPIEN - team position ien (404.57)
    62         ;POS - team position
    63         ;TPNODE - team position node (404.57)
    64         ;PRAC - practitioner info. NAME IEN^NAME^POS^POSIEN
    65         ;ROLN - role name
    66         ;PCAP - PC/AP/NPC assignment?
    67         ;PRCN - preceptor name
    68         ;
    69         N PTNAME,PID,ADATE
    70         S PTNAME=$P($G(^DPT(PIEN,0)),"^") ;patient name
    71         S PID=$P($G(^DPT(PIEN,.36)),"^",3),PID=$TR(PID,"-","")
    72         ;9 digit ssn SD*5.3*526 - dmr
    73         ;S PID=$E(PID,6,10) ;last four pid include 5th for pseudo notation
    74         ;
    75         S ADATE=$P(NODE,"^",3) ;position assignment date - fm format
    76         ;convert to external format
    77         I ADATE'="" S ADATE=$TR($$FMTE^XLFDT(ADATE,"5DF")," ","0")
    78         ;
    79         S PNAME=$P(PRAC,"^",2) ;practitioner name
    80         S PNIEN=$P(PRAC,"^") ;practitioner ien
    81         ;
    82         S TIEN=+$P(TPNODE,"^",2) ;ien team file 404.51
    83         S TMN=$G(^SCTM(404.51,TIEN,0))
    84         Q:TMN=""
    85         S TNAME=$P(TMN,"^") ;team name
    86         S PC=$P(TMN,"^",5) ;primary care team 1/0
    87         S IIEN=+$P(TMN,"^",7) ;institution ien
    88         S INAME=$P($G(^DIC(4,IIEN,0)),"^") ;institution
    89         ;
    90         D FORMAT(IIEN,INAME,TNAME,TIEN,PC,PTNAME,PID,PNAME,PNIEN,POS,TPIEN,ADATE,PIEN,ROLN,PCAP,PRCN)
    91         Q
    92         ;
    93 FORMAT(IIEN,INAME,TNAME,TIEN,PC,PTNAME,PID,PNAME,PIEN,POS,TPIEN,ADATE,PTIEN,ROLN,PCAP,PRCN)     ;
    94         ;IIEN - institution ien
    95         ;INAME - institution name
    96         ;TNAME - team name
    97         ;TIEN - team ien
    98         ;PC - primary care 1/0
    99         ;PTNAME - patient name
    100         ;PID - last 4 pid plus 5th pseudo
    101         ;PNAME - practitioner name
    102         ;PIEN - practitioner ien
    103         ;POS - position name
    104         ;TPIEN - position ien
    105         ;ADATE - assignment date
    106         ;PTIEN - patient ien
    107         ;ROLN - role name
    108         ;PCAP - PC/AP/NPC assignment?
    109         ;PRCN - preceptor name
    110         ;
    111         I INAME="" S INAME="[BAD DATA]"
    112         I TNAME="" S TNAME="[BAD DATA]"
    113         I PNAME="" S PNAME="[BAD DATA]"
    114         I '$D(@STORE@("I",INAME,IIEN)) S @STORE@("I",INAME,IIEN)=""
    115         I '$D(@STORE@("T",IIEN,TNAME,TIEN)) S @STORE@("T",IIEN,TNAME,TIEN)=""
    116         I '$D(@STORE@("P",IIEN,TIEN,PNAME,PIEN,TPIEN)) S @STORE@("P",IIEN,TIEN,PNAME,PIEN,TPIEN)=""
    117         S @STORE@(IIEN)="Division: "_INAME
    118         S @STORE@(IIEN,TIEN)="Team:  "_TNAME
    119         S $E(@STORE@(IIEN,TIEN),40)="Primary Care Team: "_$S(PC=1:"YES",1:"NO")
    120         ;
    121         S @STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN)=$E(PTNAME,1,17)
    122         S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),19)=PID
    123         S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),31)=ADATE
    124         S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),43)=PCAP
    125         S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),49)=$E(PNAME,1,21)
    126         S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),70)=$E(POS,1,20)
    127         S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),92)=$E(ROLN,1,20)
    128         S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),113)=$E(PRCN,1,20)
    129         Q
    130         ;
    131 NOTA(PTIEN,PIEN)        ;
    132         ;PTIEN - patient team assignment (#404.42)
    133         ;PIEN - patient ien
    134         N IIEN,INAME,TNAME,TIEN,PC,PTNAME,PID,PNAME,PNIEN,POSIEN,POS,TPIEN
    135         N ROLN,PCAP,PRCN,ADATE
    136         S POS="[Not Assigned]",POSIEN=0
    137         S PNAME="[Not Assigned]",PNIEN=0
    138         S (ROLN,PCAP,PRCN,ADATE)=""
    139         ;
    140         S PTNAME=$E($P($G(^DPT(PIEN,0)),"^"),1,20) ;patient name
    141         S PID=$P($G(^DPT(PIEN,.36)),"^",3),PID=$TR(PID,"-","")
    142         ;S PID=$E(PID,6,10) ;9 digit ssn patch 526
    143         ;
    144         S TIEN=+$P($G(^SCPT(404.42,PTIEN,0)),"^",3) ;team ien
    145         S TMN=$G(^SCTM(404.51,TIEN,0))
    146         Q:TMN=""
    147         S TNAME=$P(TMN,"^") ;team name
    148         S PC=$P(TMN,"^",5) ;primary care team 1/0
    149         S IIEN=+$P(TMN,"^",7) ;institution ien
    150         S INAME=$P($G(^DIC(4,IIEN,0)),"^") ;institution name
    151         ;
    152         D FORMAT(IIEN,INAME,TNAME,TIEN,PC,PTNAME,PID,PNAME,PNIEN,POS,POSIEN,ADATE,PIEN,ROLN,PCAP,PRCN)
    153         Q
     1SCRPTA2 ;ALB/CMM - Patient Listing w/Team Assignment Data ; 30 Jun 99  1:33 PM
     2 ;;5.3;Scheduling;**41,88,140,148,174,181,177**;AUG 13, 1993
     3 ;
     4 ;Patient Listing w/Team Assignment Data Report continued
     5 ;
     6CHK(PTIEN,PIEN) ;assigned to a position
     7 ;PTIEN - ien of 404.42 Patient Team Assignment file
     8 ;PIEN - ien of patient file #2
     9 ;
     10 N NODE,START,TPIEN,TPNODE,ROL,PRAC,ROLN,PCAP,PRCN
     11 S START=""
     12 Q:'$D(^SCPT(404.43,"B",PTIEN))&(PRACT'="")
     13 I '$D(^SCPT(404.43,"B",PTIEN))&(PRACT="") D NOTA(PTIEN,PIEN) Q
     14 F  S START=$O(^SCPT(404.43,"B",PTIEN,START)) Q:START=""  D
     15 .S NODE=$G(^SCPT(404.43,START,0))
     16 .Q:NODE=""
     17 .Q:($P(NODE,"^",4)'="")&($P(NODE,"^",4)<DT)
     18 .; ^ not assigned currently
     19 .S PCAP=+$P(NODE,U,5)
     20 .S TPIEN=+$P(NODE,"^",2) ;team position ien (404.57)
     21 .I '$D(^SCTM(404.57,TPIEN,0)) D NOTA(PTIEN,PIEN) Q
     22 .S TPNODE=$G(^SCTM(404.57,TPIEN,0))
     23 .I TPNODE="" D NOTA(PTIEN,PIEN) Q
     24 .S PCAP=$S('PCAP:"NPC",+$$OKPREC3^SCMCLK(TPIEN,DT)>0:" AP",1:"PCP") ; PC?
     25 .S PRCN=$P($$OKPREC2^SCMCLK(TPIEN,DT),U,2)  ;preceptor name
     26 .;
     27 .S ROL=+$P(TPNODE,"^",3) ;role for position (ien)
     28 .Q:'$D(ROLE(ROL))&(ROLE'=1)  ;not a selected role
     29 .S ROLN=$P($G(^SD(403.46,ROL,0)),U) ;role name
     30 .;
     31 .S PRAC=$$PRACI(TPIEN) ;practitioner information
     32 .I +PRAC=-1 D NOTA(PTIEN,PIEN) Q
     33 .I (PRACT'=1)&('$D(PRACT(+PRAC)))&(+PRAC'=0) Q
     34 .; ^ not a selected practitioner
     35 .;
     36 .S POS=$P($G(^SCTM(404.57,TPIEN,0)),"^")
     37 .D FOUND2(START,NODE,TPIEN,POS,TPNODE,PRAC,PIEN,ROLN,PCAP,PRCN)
     38 Q
     39PRACI(TPIEN) ;
     40 ;TPIEN - team position ien (404.57)
     41 ;
     42 N EN,TPLIST,TPERR,NAME,POS,ERR,NPIEN,NODE,POSIEN
     43 S TPLIST="TPLST",TPERR="ERR2"
     44 K @TPLIST,@TPERR
     45 S ERR=$$PRTP^SCAPMC8(TPIEN,,.TPLIST,.TPERR)
     46 Q:ERR=0!($D(@TPERR)) -1
     47 S NODE=$G(@TPLIST@(1))
     48 Q:NODE="" "0^[Not Assigned]"
     49 S NAME=$P(NODE,"^",2) ;practitioner name
     50 S NPIEN=+$P(NODE,"^") ;practitioner ien
     51 S POS=$P(NODE,"^",4) ;position name
     52 S POSIEN=+$P(NODE,"^",3) ;position ien
     53 I POS="" S POS="[Not Assigned]",POSIEN=0
     54 I NAME="" S NAME="[Not Assigned]",NPIEN=0
     55 K @TPLIST,@TPERR
     56 Q NPIEN_"^"_NAME_"^"_POS_"^"_POSIEN
     57 ;
     58FOUND2(START,NODE,TPIEN,POS,TPNODE,PRAC,PIEN,ROLN,PCAP,PRCN) ;
     59 ;START - patient team assignment position ien
     60 ;NODE - patient team position assignment node
     61 ;TPIEN - team position ien (404.57)
     62 ;POS - team position
     63 ;TPNODE - team position node (404.57)
     64 ;PRAC - practitioner info. NAME IEN^NAME^POS^POSIEN
     65 ;ROLN - role name
     66 ;PCAP - PC/AP/NPC assignment?
     67 ;PRCN - preceptor name
     68 ;
     69 N PTNAME,PID,ADATE
     70 S PTNAME=$P($G(^DPT(PIEN,0)),"^") ;patient name
     71 S PID=$P($G(^DPT(PIEN,.36)),"^",3),PID=$TR(PID,"-","")
     72 S PID=$E(PID,6,10) ;last four pid include 5th for pseudo notation
     73 ;
     74 S ADATE=$P(NODE,"^",3) ;position assignment date - fm format
     75 ;convert to external format
     76 I ADATE'="" S ADATE=$TR($$FMTE^XLFDT(ADATE,"5DF")," ","0")
     77 ;
     78 S PNAME=$P(PRAC,"^",2) ;practitioner name
     79 S PNIEN=$P(PRAC,"^") ;practitioner ien
     80 ;
     81 S TIEN=+$P(TPNODE,"^",2) ;ien team file 404.51
     82 S TMN=$G(^SCTM(404.51,TIEN,0))
     83 Q:TMN=""
     84 S TNAME=$P(TMN,"^") ;team name
     85 S PC=$P(TMN,"^",5) ;primary care team 1/0
     86 S IIEN=+$P(TMN,"^",7) ;institution ien
     87 S INAME=$P($G(^DIC(4,IIEN,0)),"^") ;institution
     88 ;
     89 D FORMAT(IIEN,INAME,TNAME,TIEN,PC,PTNAME,PID,PNAME,PNIEN,POS,TPIEN,ADATE,PIEN,ROLN,PCAP,PRCN)
     90 Q
     91 ;
     92FORMAT(IIEN,INAME,TNAME,TIEN,PC,PTNAME,PID,PNAME,PIEN,POS,TPIEN,ADATE,PTIEN,ROLN,PCAP,PRCN) ;
     93 ;IIEN - institution ien
     94 ;INAME - institution name
     95 ;TNAME - team name
     96 ;TIEN - team ien
     97 ;PC - primary care 1/0
     98 ;PTNAME - patient name
     99 ;PID - last 4 pid plus 5th pseudo
     100 ;PNAME - practitioner name
     101 ;PIEN - practitioner ien
     102 ;POS - position name
     103 ;TPIEN - position ien
     104 ;ADATE - assignment date
     105 ;PTIEN - patient ien
     106 ;ROLN - role name
     107 ;PCAP - PC/AP/NPC assignment?
     108 ;PRCN - preceptor name
     109 ;
     110 I INAME="" S INAME="[BAD DATA]"
     111 I TNAME="" S TNAME="[BAD DATA]"
     112 I PNAME="" S PNAME="[BAD DATA]"
     113 I '$D(@STORE@("I",INAME,IIEN)) S @STORE@("I",INAME,IIEN)=""
     114 I '$D(@STORE@("T",IIEN,TNAME,TIEN)) S @STORE@("T",IIEN,TNAME,TIEN)=""
     115 I '$D(@STORE@("P",IIEN,TIEN,PNAME,PIEN,TPIEN)) S @STORE@("P",IIEN,TIEN,PNAME,PIEN,TPIEN)=""
     116 S @STORE@(IIEN)="Division: "_INAME
     117 S @STORE@(IIEN,TIEN)="Team:  "_TNAME
     118 S $E(@STORE@(IIEN,TIEN),40)="Primary Care Team: "_$S(PC=1:"YES",1:"NO")
     119 ;
     120 S @STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN)=$E(PTNAME,1,21)
     121 S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),24)=PID
     122 S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),31)=ADATE
     123 S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),43)=PCAP
     124 S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),49)=$E(PNAME,1,21)
     125 S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),70)=$E(POS,1,20)
     126 S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),92)=$E(ROLN,1,20)
     127 S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),113)=$E(PRCN,1,20)
     128 Q
     129 ;
     130NOTA(PTIEN,PIEN) ;
     131 ;PTIEN - patient team assignment (#404.42)
     132 ;PIEN - patient ien
     133 N IIEN,INAME,TNAME,TIEN,PC,PTNAME,PID,PNAME,PNIEN,POSIEN,POS,TPIEN
     134 N ROLN,PCAP,PRCN,ADATE
     135 S POS="[Not Assigned]",POSIEN=0
     136 S PNAME="[Not Assigned]",PNIEN=0
     137 S (ROLN,PCAP,PRCN,ADATE)=""
     138 ;
     139 S PTNAME=$E($P($G(^DPT(PIEN,0)),"^"),1,20) ;patient name
     140 S PID=$P($G(^DPT(PIEN,.36)),"^",3),PID=$TR(PID,"-","")
     141 S PID=$E(PID,6,10) ;last 4 plus 5th for psuedo
     142 ;
     143 S TIEN=+$P($G(^SCPT(404.42,PTIEN,0)),"^",3) ;team ien
     144 S TMN=$G(^SCTM(404.51,TIEN,0))
     145 Q:TMN=""
     146 S TNAME=$P(TMN,"^") ;team name
     147 S PC=$P(TMN,"^",5) ;primary care team 1/0
     148 S IIEN=+$P(TMN,"^",7) ;institution ien
     149 S INAME=$P($G(^DIC(4,IIEN,0)),"^") ;institution name
     150 ;
     151 D FORMAT(IIEN,INAME,TNAME,TIEN,PC,PTNAME,PID,PNAME,PNIEN,POS,POSIEN,ADATE,PIEN,ROLN,PCAP,PRCN)
     152 Q

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPTM.m

    r613 r623  
    1 SCRPTM  ;ALB/CMM - List of Team's Members Report ; 29 Jun 99  04:11PM
    2         ;;5.3;Scheduling;**41,48,52,181,177,520**;AUG 13, 1993;Build 26
    3         ;
    4         ;List of Team's Members Report
    5         ;
    6 PROMPTS ;
    7         ;Prompt for Institution, Team, Date Range, User Class, Role
    8         ;and Print device
    9         ;
    10         N VAUTD,VAUTT,VAUTUC,VAUTR,QTIME,RANG,PRNT,NUMBER
    11         K VAUTD,VAUTT,VAUTUC,VAUTR,SCUP
    12         S QTIME=""
    13         W ! D INST^SCRPU1 I Y=-1 G ERR
    14         W ! K Y D PRMTT^SCRPU1 I '$D(VAUTT) G ERR
    15         W ! K Y S RANG=$$DTRANG^SCRPU2() I +RANG=-1 G ERR
    16         W ! K Y D USER^SCRPU1 I '$D(VAUTUC)&($P($G(^SD(404.91,1,"PCMM")),"^")=1) G ERR
    17         W ! K Y D ROLE^SCRPU1 I '$D(VAUTR) G ERR
    18         D QUE(.VAUTD,.VAUTT,.VAUTUC,.VAUTR,RANG) Q
    19         ;
    20 QUE(INST,TEAM,USERC,ROLE,RANGE) ;queue report
    21         ;Input Parameters:
    22         ;INST - institutions selected (variable and array)
    23         ;TEAM - teams selected (variable and array)
    24         ;USERC - user classes selected (variable and array)
    25         ;ROLE - roles selected (variable and array)
    26         ;RANGE - date range selected (begin date ^ end date)
    27         N ZTSAVE,II
    28         F II="INST","TEAM","USERC","ROLE","INST(","TEAM(","USERC(","ROLE(","RANGE" S ZTSAVE(II)=""
    29         W ! D EN^XUTMDEVQ("QENTRY^SCRPTM","Team Member Listing",.ZTSAVE)
    30         Q
    31         ;
    32 ENTRY2(INST,TEAM,USERC,ROLE,RANGE,IOP,ZTDTH)    ;
    33         ;Second entry point for GUI to use
    34         ;Input Parameters:
    35         ;INST - institutions selected (variable and array)
    36         ;TEAM - teams selected (variable and array)
    37         ;USERC - user classes selected (variable and array)
    38         ;ROLE - roles selected (variable and array)
    39         ;RANGE - date range selected (begin date ^ end date)
    40         ;IOP - print device
    41         ;ZTDTH - queue time (optional)
    42         ;
    43         ;validate parameters
    44         I '$D(INST)!'$D(TEAM)!'$D(ROLE)!'$D(RANGE)!'$D(IOP)!(IOP="") Q
    45         ;
    46         N NUMBER
    47         S IOST=$P(IOP,"^",2),IOP=$P(IOP,"^")
    48         I IOP?1"Q;".E S IOP=$P(IOP,"Q;",2)
    49         I IOST?1"C-".E D QENTRY G RET
    50         I ZTDTH="" S ZTDTH=$H
    51         S ZTRTN="QENTRY^SCRPTM"
    52         S ZTDESC="List of Team's Members",ZTIO=IOP
    53         N II
    54         F II="INST","TEAM","USERC","ROLE","INST(","TEAM(","USERC(","ROLE(","RANGE","IOP" S ZTSAVE(II)=""
    55         D ^%ZTLOAD
    56 RET     S NUMBER=0
    57         I $D(ZTSK) S NUMBER=ZTSK
    58         D EXIT1
    59         Q NUMBER
    60         ;
    61 QENTRY  ;
    62         ;driver entry point
    63         S TITL="Team Member Listing"
    64         S STORE="^TMP("_$J_",""SCRPTM"")"
    65         K @STORE
    66         S @STORE=0
    67         D BUILD
    68         I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL)
    69         I '$D(NODATA) D PRINTIT(STORE,TITL)
    70         D EXIT2
    71         Q
    72         ;
    73 ERR     ;
    74 EXIT1   ;
    75         K ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE,SCUP
    76         Q
    77 EXIT2   ;
    78         K @STORE
    79         K STOP,STORE,TITL,IOP,TEAM,INST,NODATA,RANGE,ROLE,USERC
    80         Q
    81         ;
    82 BUILD   ;get report data
    83         ;get all practitioners for all teams selected
    84         I TEAM=1 D TALL ;all teams selected
    85         N TIEN,OKAY,XLIST,YLIST,SCTP,SCI,SCDT,PLIST
    86         S SCDT("BEGIN")=$P(RANGE,U),SCDT("END")=$P(RANGE,U,2)
    87         S SCDT("INCL")=0,SCDT="SCDT"
    88         S TIEN="",PLIST="^TMP(""SCRP"",$J,""LIST"")"
    89         F  S TIEN=$O(TEAM(TIEN)) Q:TIEN=""!(TIEN'?.N)  D
    90         .K XLIST,@PLIST
    91         .S OKAY=$$TPTM^SCAPMC(TIEN,.SCDT,"","","XLIST","ERROR")
    92         .S SCTP=0 F  S SCTP=$O(XLIST("SCTP",TIEN,SCTP)) Q:'SCTP  D
    93         ..S SCTP0=$G(^SCTM(404.57,SCTP,0)) Q:'$L(SCTP0)
    94         ..I ROLE'=1,'$D(ROLE(+$P(SCTP0,U,3))) Q  ;not a selected role
    95         ..I $D(USERC),USERC'=1,'$D(USERC(+$P(SCTP0,U,13))) Q  ;not a selected user class
    96         ..K YLIST
    97         ..S OKAY=$$PRTP^SCAPMC(SCTP,.SCDT,"YLIST","ERROR",1,0)
    98         ..S SCI=0 F  S SCI=$O(YLIST(SCI)) Q:'SCI  D
    99         ...S @PLIST@(0)=$G(@PLIST@(0))+1
    100         ...S @PLIST@(@PLIST@(0))=YLIST(SCI)
    101         ...Q
    102         ..Q
    103         .I OKAY D PULL^SCRPTM2(TIEN,.PLIST)
    104         .Q
    105         Q
    106         ;
    107 TALL    ;
    108         ;get all active team for divisions selected
    109         N NXT,IIEN,NODE
    110         S NXT=0,IIEN=""
    111         ;$O through team file and find all active teams for selected divisions
    112         F  S IIEN=$O(^SCTM(404.51,"AINST",IIEN)) Q:IIEN=""  D
    113         .I INST=1!$D(INST(IIEN)) D
    114         ..S TIEN=0
    115         ..F  S TIEN=$O(^SCTM(404.51,"AINST",IIEN,TIEN)) Q:TIEN=""  D
    116         ...I $$ACTTM^SCMCTMU(TIEN) S TEAM(TIEN)=""
    117         Q
    118         ;
    119 PRINTIT(STORE,TITL)     ;
    120         N INST,EINST,ETEAM,TEM,EPRACT,PRACT,PAGE,NXT,NPAGE,CNT,HEAD,POS
    121         S EINST="",(NPAGE,STOP,HEAD)=0,PAGE=1 W:$E(IOST)="C" @IOF
    122         D TITLE^SCRPU3(.PAGE,TITL)
    123         F  S EINST=$O(@STORE@("I",EINST)) Q:EINST=""!(STOP)  D
    124         .S INST=$O(@STORE@("I",EINST,""))
    125         .Q:INST=""
    126         .I 'NPAGE W !,$G(@STORE@(INST)) ;write institution line
    127         .S (ETEAM,TEM)=""
    128         .F  S ETEAM=$O(@STORE@("T",INST,ETEAM)) Q:ETEAM=""!(STOP)  D
    129         ..S TEM=$O(@STORE@("T",INST,ETEAM,0))
    130         ..I TEM="" Q
    131         ..S NXT="H"
    132         ..I NPAGE,(IOST'?1"C-".E) D NEWP^SCRPTM2(INST,TEM,TITL,.PAGE,.HEAD) S NPAGE=0
    133         ..I NPAGE,(IOST?1"C-".E) D HOLD1^SCRPTM2(.PAGE,TITL,INST,TEM,.HEAD) S NPAGE=0
    134         ..I STOP Q
    135         ..I IOST'?1"C-".E,$Y>(IOSL-5) D NEWP^SCRPTM2(INST,TEM,TITL,.PAGE,.HEAD)
    136         ..I IOST?1"C-".E,$Y>(IOSL-5) D HOLD1^SCRPTM2(.PAGE,TITL,INST,TEM,.HEAD)
    137         ..I STOP Q
    138         ..F  S NXT=$O(@STORE@(INST,TEM,NXT)) Q:NXT'?1"H".E!(STOP)  D
    139         ...I 'HEAD W !,$G(@STORE@(INST,TEM,NXT)) S HEAD=0 ;writes team info
    140         ..S (EPRACT,PRACT)=""
    141         ..W ! ;extra line between members and practioner list
    142         ..F  S EPRACT=$O(@STORE@("PN",INST,TEM,EPRACT)) Q:EPRACT=""!(STOP)  D
    143         ...F  S PRACT=$O(@STORE@("PN",INST,TEM,EPRACT,PRACT)) Q:PRACT=""!(STOP)  D
    144         ....I PRACT="" Q
    145         ....S POS=""
    146         ....F  S POS=$O(@STORE@("PN",INST,TEM,EPRACT,PRACT,POS)) Q:POS=""!(STOP)  D
    147         .....D PRNTD(INST,TEM,PRACT,POS,TITL,.PAGE,.HEAD)
    148         .....W ! ;seperated positions
    149         ....W ! ;separates practitioners
    150         .S NPAGE=1
    151         I 'STOP,$E(IOST)="C" N DIR S DIR(0)="E" W ! D ^DIR
    152         Q
    153         ;
    154 PRNTD(INST,TEM,PRACT,POS,TITL,PAGE,HEAD)        ;
    155         ;
    156         N CNT,SCAC
    157         S CNT=""
    158         I IOST'?1"C-".E,$Y>(IOSL-11) D NEWP^SCRPTM2(INST,TEM,TITL,.PAGE,.HEAD)
    159         I IOST?1"C-".E,$Y>(IOSL-11) D HOLD1^SCRPTM2(.PAGE,TITL,INST,TEM,.HEAD)
    160         I STOP Q
    161         F  S CNT=$O(@STORE@(INST,TEM,PRACT,POS,CNT)) Q:CNT=""!(STOP)  D
    162         .W !,$G(@STORE@(INST,TEM,PRACT,POS,CNT))
    163         .S SCAC="" I CNT=4  D
    164         ..F  S SCAC=$O(@STORE@(INST,TEM,PRACT,POS,4,SCAC)) Q:SCAC=""!(STOP)  D
    165         ...W !,$G(@STORE@(INST,TEM,PRACT,POS,4,SCAC))
    166         Q
     1SCRPTM ;ALB/CMM - List of Team's Members Report ; 29 Jun 99  04:11PM
     2 ;;5.3;Scheduling;**41,48,52,181,177**;AUG 13, 1993
     3 ;
     4 ;List of Team's Members Report
     5 ;
     6PROMPTS ;
     7 ;Prompt for Institution, Team, Date Range, User Class, Role
     8 ;and Print device
     9 ;
     10 N VAUTD,VAUTT,VAUTUC,VAUTR,QTIME,RANG,PRNT,NUMBER
     11 K VAUTD,VAUTT,VAUTUC,VAUTR,SCUP
     12 S QTIME=""
     13 W ! D INST^SCRPU1 I Y=-1 G ERR
     14 W ! K Y D PRMTT^SCRPU1 I '$D(VAUTT) G ERR
     15 W ! K Y S RANG=$$DTRANG^SCRPU2() I +RANG=-1 G ERR
     16 W ! K Y D USER^SCRPU1 I '$D(VAUTUC)&($P($G(^SD(404.91,1,"PCMM")),"^")=1) G ERR
     17 W ! K Y D ROLE^SCRPU1 I '$D(VAUTR) G ERR
     18 D QUE(.VAUTD,.VAUTT,.VAUTUC,.VAUTR,RANG) Q
     19 ;
     20QUE(INST,TEAM,USERC,ROLE,RANGE) ;queue report
     21 ;Input Parameters:
     22 ;INST - institutions selected (variable and array)
     23 ;TEAM - teams selected (variable and array)
     24 ;USERC - user classes selected (variable and array)
     25 ;ROLE - roles selected (variable and array)
     26 ;RANGE - date range selected (begin date ^ end date)
     27 N ZTSAVE,II
     28 F II="INST","TEAM","USERC","ROLE","INST(","TEAM(","USERC(","ROLE(","RANGE" S ZTSAVE(II)=""
     29 W ! D EN^XUTMDEVQ("QENTRY^SCRPTM","Team Member Listing",.ZTSAVE)
     30 Q
     31 ;
     32ENTRY2(INST,TEAM,USERC,ROLE,RANGE,IOP,ZTDTH) ;
     33 ;Second entry point for GUI to use
     34 ;Input Parameters:
     35 ;INST - institutions selected (variable and array)
     36 ;TEAM - teams selected (variable and array)
     37 ;USERC - user classes selected (variable and array)
     38 ;ROLE - roles selected (variable and array)
     39 ;RANGE - date range selected (begin date ^ end date)
     40 ;IOP - print device
     41 ;ZTDTH - queue time (optional)
     42 ;
     43 ;validate parameters
     44 I '$D(INST)!'$D(TEAM)!'$D(ROLE)!'$D(RANGE)!'$D(IOP)!(IOP="") Q
     45 ;
     46 N NUMBER
     47 S IOST=$P(IOP,"^",2),IOP=$P(IOP,"^")
     48 I IOP?1"Q;".E S IOP=$P(IOP,"Q;",2)
     49 I IOST?1"C-".E D QENTRY G RET
     50 I ZTDTH="" S ZTDTH=$H
     51 S ZTRTN="QENTRY^SCRPTM"
     52 S ZTDESC="List of Team's Members",ZTIO=IOP
     53 N II
     54 F II="INST","TEAM","USERC","ROLE","INST(","TEAM(","USERC(","ROLE(","RANGE","IOP" S ZTSAVE(II)=""
     55 D ^%ZTLOAD
     56RET S NUMBER=0
     57 I $D(ZTSK) S NUMBER=ZTSK
     58 D EXIT1
     59 Q NUMBER
     60 ;
     61QENTRY ;
     62 ;driver entry point
     63 S TITL="Team Member Listing"
     64 S STORE="^TMP("_$J_",""SCRPTM"")"
     65 K @STORE
     66 S @STORE=0
     67 D BUILD
     68 I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL)
     69 I '$D(NODATA) D PRINTIT(STORE,TITL)
     70 D EXIT2
     71 Q
     72 ;
     73ERR ;
     74EXIT1 ;
     75 K ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE,SCUP
     76 Q
     77EXIT2 ;
     78 K @STORE
     79 K STOP,STORE,TITL,IOP,TEAM,INST,NODATA,RANGE,ROLE,USERC
     80 Q
     81 ;
     82BUILD ;get report data
     83 ;get all practitioners for all teams selected
     84 I TEAM=1 D TALL ;all teams selected
     85 N TIEN,OKAY,XLIST,YLIST,SCTP,SCI,SCDT,PLIST
     86 S SCDT("BEGIN")=$P(RANGE,U),SCDT("END")=$P(RANGE,U,2)
     87 S SCDT("INCL")=0,SCDT="SCDT"
     88 S TIEN="",PLIST="^TMP(""SCRP"",$J,""LIST"")"
     89 F  S TIEN=$O(TEAM(TIEN)) Q:TIEN=""!(TIEN'?.N)  D
     90 .K XLIST,@PLIST
     91 .S OKAY=$$TPTM^SCAPMC(TIEN,.SCDT,"","","XLIST","ERROR")
     92 .S SCTP=0 F  S SCTP=$O(XLIST("SCTP",TIEN,SCTP)) Q:'SCTP  D
     93 ..S SCTP0=$G(^SCTM(404.57,SCTP,0)) Q:'$L(SCTP0)
     94 ..I ROLE'=1,'$D(ROLE(+$P(SCTP0,U,3))) Q  ;not a selected role
     95 ..I $D(USERC),USERC'=1,'$D(USERC(+$P(SCTP0,U,13))) Q  ;not a selected user class
     96 ..K YLIST
     97 ..S OKAY=$$PRTP^SCAPMC(SCTP,.SCDT,"YLIST","ERROR",1,0)
     98 ..S SCI=0 F  S SCI=$O(YLIST(SCI)) Q:'SCI  D
     99 ...S @PLIST@(0)=$G(@PLIST@(0))+1
     100 ...S @PLIST@(@PLIST@(0))=YLIST(SCI)
     101 ...Q
     102 ..Q
     103 .I OKAY D PULL^SCRPTM2(TIEN,.PLIST)
     104 .Q
     105 Q
     106 ;
     107TALL ;
     108 ;get all active team for divisions selected
     109 N NXT,IIEN,NODE
     110 S NXT=0,IIEN=""
     111 ;$O through team file and find all active teams for selected divisions
     112 F  S IIEN=$O(^SCTM(404.51,"AINST",IIEN)) Q:IIEN=""  D
     113 .I INST=1!$D(INST(IIEN)) D
     114 ..S TIEN=0
     115 ..F  S TIEN=$O(^SCTM(404.51,"AINST",IIEN,TIEN)) Q:TIEN=""  D
     116 ...I $$ACTTM^SCMCTMU(TIEN) S TEAM(TIEN)=""
     117 Q
     118 ;
     119PRINTIT(STORE,TITL) ;
     120 N INST,EINST,ETEAM,TEM,EPRACT,PRACT,PAGE,NXT,NPAGE,CNT,HEAD,POS
     121 S EINST="",(NPAGE,STOP,HEAD)=0,PAGE=1 W:$E(IOST)="C" @IOF
     122 D TITLE^SCRPU3(.PAGE,TITL)
     123 F  S EINST=$O(@STORE@("I",EINST)) Q:EINST=""!(STOP)  D
     124 .S INST=$O(@STORE@("I",EINST,""))
     125 .Q:INST=""
     126 .I 'NPAGE W !,$G(@STORE@(INST)) ;write institution line
     127 .S (ETEAM,TEM)=""
     128 .F  S ETEAM=$O(@STORE@("T",INST,ETEAM)) Q:ETEAM=""!(STOP)  D
     129 ..S TEM=$O(@STORE@("T",INST,ETEAM,0))
     130 ..I TEM="" Q
     131 ..S NXT="H"
     132 ..I NPAGE,(IOST'?1"C-".E) D NEWP^SCRPTM2(INST,TEM,TITL,.PAGE,.HEAD) S NPAGE=0
     133 ..I NPAGE,(IOST?1"C-".E) D HOLD1^SCRPTM2(.PAGE,TITL,INST,TEM,.HEAD) S NPAGE=0
     134 ..I STOP Q
     135 ..I IOST'?1"C-".E,$Y>(IOSL-5) D NEWP^SCRPTM2(INST,TEM,TITL,.PAGE,.HEAD)
     136 ..I IOST?1"C-".E,$Y>(IOSL-5) D HOLD1^SCRPTM2(.PAGE,TITL,INST,TEM,.HEAD)
     137 ..I STOP Q
     138 ..F  S NXT=$O(@STORE@(INST,TEM,NXT)) Q:NXT'?1"H".E!(STOP)  D
     139 ...I 'HEAD W !,$G(@STORE@(INST,TEM,NXT)) S HEAD=0 ;writes team info
     140 ..S (EPRACT,PRACT)=""
     141 ..W ! ;extra line between members and practioner list
     142 ..F  S EPRACT=$O(@STORE@("PN",INST,TEM,EPRACT)) Q:EPRACT=""!(STOP)  D
     143 ...F  S PRACT=$O(@STORE@("PN",INST,TEM,EPRACT,PRACT)) Q:PRACT=""!(STOP)  D
     144 ....I PRACT="" Q
     145 ....S POS=""
     146 ....F  S POS=$O(@STORE@("PN",INST,TEM,EPRACT,PRACT,POS)) Q:POS=""!(STOP)  D
     147 .....D PRNTD(INST,TEM,PRACT,POS,TITL,.PAGE,.HEAD)
     148 .....W ! ;seperated positions
     149 ....W ! ;separates practitioners
     150 .S NPAGE=1
     151 I 'STOP,$E(IOST)="C" N DIR S DIR(0)="E" W ! D ^DIR
     152 Q
     153 ;
     154PRNTD(INST,TEM,PRACT,POS,TITL,PAGE,HEAD) ;
     155 ;
     156 N CNT
     157 S CNT=""
     158 I IOST'?1"C-".E,$Y>(IOSL-11) D NEWP^SCRPTM2(INST,TEM,TITL,.PAGE,.HEAD)
     159 I IOST?1"C-".E,$Y>(IOSL-11) D HOLD1^SCRPTM2(.PAGE,TITL,INST,TEM,.HEAD)
     160 I STOP Q
     161 F  S CNT=$O(@STORE@(INST,TEM,PRACT,POS,CNT)) Q:CNT=""!(STOP)  D
     162 .W !,$G(@STORE@(INST,TEM,PRACT,POS,CNT))
     163 Q

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPTM2.m

    r613 r623  
    1 SCRPTM2 ;ALB/CMM - List of Team's Members Report Continued;01/29/96 ; 29 Jun 99  04:11PM
    2         ;;5.3;Scheduling;**41,140,177,520**;AUG 13, 1993;Build 26
    3         ;
    4         ;List of Team's Members Report
    5         ;
    6 PULL(TIEN,PLIST)        ;
    7         ;TIEN - team file ien
    8         ;PLIST - array of positions and their practitioners
    9         ;
    10         N PNAME,TPIEN,ACT,INACT,RNAME,UNAME,CNT,NODE,TNODE,PCLIN,TNAME,SCI
    11         N TPHONE,TPC,INS,INAME,PRIEN,PRNAME,OPH,ROOM,SERV,TPNODE,PRCP,PCLASS
    12         ;
    13         S CNT=0
    14         F  S CNT=$O(@PLIST@(CNT)) Q:CNT=""!(CNT'?.N)  D
    15         .;get each practitioner/position
    16         .S NODE=$G(@PLIST@(CNT))
    17         .S TPIEN=+$P(NODE,"^",3) ;team position ien
    18         .S PNAME=$P(NODE,"^",4) ;position name
    19         .S ACT=$P(NODE,"^",9) ;active date (fm)
    20         .I ACT'=""&(ACT'=0) S ACT=$TR($$FMTE^XLFDT(ACT,"5DF")," ","0")
    21         .S INACT=$P(NODE,"^",10) ;inactive date (fm)
    22         .I INACT'=""&(INACT'=0) S INACT=$TR($$FMTE^XLFDT(INACT,"5DF")," ","0")
    23         .S RNAME=$P(NODE,"^",8) ;standard role name
    24         .S UNAME=$P(NODE,"^",6) ;user class name
    25         .S PRIEN=+$P(NODE,"^") ;practitioner ien
    26         .S PRNAME=$P(NODE,"^",2) ;practitioner name
    27         .;
    28         .;Get person class information
    29         .S PCLASS=$$GET^XUA4A72(PRIEN)
    30         .F SCI=1,2,3 S PCLASS(SCI)=$P(PCLASS,U,(SCI+1))
    31         .;
    32         .S TPNODE=$G(^SCTM(404.57,+TPIEN,0))
    33         .D SETASCL^SCRPRAC2(TPIEN,.PCLIN)
    34         .S PCLIN=$G(PCLIN(0))
    35         .;S PCLIN=+$P(TPNODE,"^",9) ;associated clinic ien
    36         .;S PCLIN=$P($G(^SC(PCLIN,0)),"^") ;associated clinic name
    37         .;
    38         .;Get preceptor
    39         .S PRCP=$P($$OKPREC2^SCMCLK(TPIEN,DT),U,2)
    40         .;
    41         .S TNODE=$G(^SCTM(404.51,TIEN,0)) ;team node
    42         .S TNAME=$P(TNODE,"^") ;team name
    43         .S TPHONE=$P(TNODE,"^",2) ;team phone
    44         .S TPC=$S($P(TNODE,"^",5)=1:"YES",1:"NO") ;primary care?
    45         .S INS=+$P(TNODE,"^",7) ;team division ien
    46         .S INAME=$P($G(^DIC(4,INS,0)),"^") ;team division name
    47         .D KTEAM(TNAME,TPHONE,TPC,INAME,TIEN,INS)
    48         .;
    49         .S OPH=$P($G(^VA(200,PRIEN,.13)),"^",2) ;office phone
    50         .S ROOM=$P($G(^VA(200,PRIEN,.14)),"^") ;room
    51         .S SERV=+$P($G(^VA(200,PRIEN,5)),"^") ;service/section ien
    52         .S SERV=$P($G(^DIC(49,SERV,0)),"^") ;service/section name
    53         .;
    54         .D FORMAT(PNAME,TPIEN,PCLIN,RNAME,UNAME,ACT,INACT,PRIEN,PRNAME,OPH,ROOM,SERV,INS,TIEN,PRCP,.PCLASS)
    55         .N SCAC
    56         .S SCAC=0
    57         .F  S SCAC=$O(PCLIN(SCAC)) Q:SCAC=""  D FORMATAC(INS,TIEN,PRIEN,TPIEN,PCLIN(SCAC))
    58         Q
    59         ;
    60 KTEAM(TNAME,TPHONE,TPC,TDIV,TIEN,IEND)  ;
    61         ;store team information
    62         I TDIV="" S TDIV="[BAD DATA]"
    63         I TNAME="" S TNAME="[BDA DATA]"
    64         S @STORE@("I",TDIV,IEND)=""
    65         S @STORE@("T",IEND,TNAME,TIEN)=""
    66         S @STORE@(IEND)="Division: "_TDIV
    67         S @STORE@(IEND,TIEN,"H1")="Team Name: "_TNAME
    68         S $E(@STORE@(IEND,TIEN,"H1"),40)="Team Phone: "_TPHONE
    69         S @STORE@(IEND,TIEN,"H2")="Primary Care Team: "_TPC
    70         S @STORE@(IEND,TIEN,"H3")=""
    71         S @STORE@(IEND,TIEN,"H4")="Members:"
    72         Q
    73         ;
    74 FORMAT(POS,TPIEN,PCLIN,SPOS,UCLASS,BEG,END,PIEN,PRACT,OPH,ROOM,SERV,DIV,TEM,PRCP,PCLASS)        ;
    75         ;POS - position name
    76         ;TPIEN - position ien
    77         ;PCLIN - associated clinic
    78         ;SPOS - standard  position
    79         ;UCLASS - user class
    80         ;BEG - begin date
    81         ;END - end date
    82         ;PIEN - ien of new person file
    83         ;PRACT - practitioner name
    84         ;OPH - office number
    85         ;ROOM - room
    86         ;SERV - service
    87         ;DIV - ien of division
    88         ;TEM - ien of team
    89         ;PRCP - preceptor
    90         ;PCLASS - person class
    91         ;
    92         N SCI
    93         I PRACT="" S PRACT="[BAD DATA]"
    94         S @STORE@("PN",DIV,TEM,PRACT,PIEN,TPIEN)=""
    95         S @STORE@(DIV,TEM,PIEN,TPIEN,1)=PRACT
    96         S $E(@STORE@(DIV,TEM,PIEN,TPIEN,1),35)="Position: "_POS
    97         S @STORE@(DIV,TEM,PIEN,TPIEN,2)="Standard Role: "_SPOS
    98         S @STORE@(DIV,TEM,PIEN,TPIEN,3)="User Class: "_UCLASS
    99         S @STORE@(DIV,TEM,PIEN,TPIEN,4)=SERV
    100         S $E(@STORE@(DIV,TEM,PIEN,TPIEN,4),35)="Assoc Clinic: "_PCLIN
    101         S @STORE@(DIV,TEM,PIEN,TPIEN,5)="Office Phone: "_OPH
    102         S $E(@STORE@(DIV,TEM,PIEN,TPIEN,5),35)="Room: "_ROOM
    103         S @STORE@(DIV,TEM,PIEN,TPIEN,6)="Begin Date: "_BEG
    104         S $E(@STORE@(DIV,TEM,PIEN,TPIEN,6),35)="End Date: "_END
    105         S SCI=7
    106         I $L(PRCP) S @STORE@(DIV,TEM,PIEN,TPIEN,SCI)="Preceptor: "_PRCP,SCI=8
    107         I $L(PCLASS(1)) S @STORE@(DIV,TEM,PIEN,TPIEN,SCI)="Person Class: "_PCLASS(1),SCI=SCI+1
    108         I $L(PCLASS(2)) S @STORE@(DIV,TEM,PIEN,TPIEN,SCI)="                 "_PCLASS(2),SCI=SCI+1
    109         I $L(PCLASS(3)) S @STORE@(DIV,TEM,PIEN,TPIEN,SCI)="                    "_PCLASS(3)
    110         Q
    111         ;
    112 FORMATAC(DIV,TEM,PIEN,TPIEN,PCLIN)      ;
    113         S $E(@STORE@(DIV,TEM,PIEN,TPIEN,4,SCAC),49)=$E(PCLIN,1,30)
    114         Q
    115         ;
    116 NEWP(INST,TEM,TITL,PAGE,HEAD)   ;
    117         ;new page
    118         D NEWP1^SCRPU3(.PAGE,TITL)
    119         D HEAD1(INST,TEM,.HEAD)
    120         Q
    121         ;
    122 HEAD1(INST,TEM,HEAD)    ;
    123         ;write headings
    124         W !,$G(@STORE@(INST))
    125         N NXT
    126         S NXT="H"
    127         F  S NXT=$O(@STORE@(INST,TEM,NXT)) Q:NXT'?1"H".E  D
    128         .W !,$G(@STORE@(INST,TEM,NXT))
    129         W ! ;extra line between MEMBERS and practitioner list
    130         S HEAD=1
    131         Q
    132 HOLD1(PAGE,TITL,INST,TEM,HEAD)  ;
    133         ;device is home, reached end of page
    134         D HOLD^SCRPU3(.PAGE,TITL)
    135         I STOP Q
    136         D HEAD1(INST,TEM,.HEAD)
    137         Q
     1SCRPTM2 ;ALB/CMM - List of Team's Members Report Continued;01/29/96 ; 29 Jun 99  04:11PM
     2 ;;5.3;Scheduling;**41,140,177**;AUG 13, 1993
     3 ;
     4 ;List of Team's Members Report
     5 ;
     6PULL(TIEN,PLIST) ;
     7 ;TIEN - team file ien
     8 ;PLIST - array of positions and their practitioners
     9 ;
     10 N PNAME,TPIEN,ACT,INACT,RNAME,UNAME,CNT,NODE,TNODE,PCLIN,TNAME,SCI
     11 N TPHONE,TPC,INS,INAME,PRIEN,PRNAME,OPH,ROOM,SERV,TPNODE,PRCP,PCLASS
     12 ;
     13 S CNT=0
     14 F  S CNT=$O(@PLIST@(CNT)) Q:CNT=""!(CNT'?.N)  D
     15 .;get each practitioner/position
     16 .S NODE=$G(@PLIST@(CNT))
     17 .S TPIEN=+$P(NODE,"^",3) ;team position ien
     18 .S PNAME=$P(NODE,"^",4) ;position name
     19 .S ACT=$P(NODE,"^",9) ;active date (fm)
     20 .I ACT'=""&(ACT'=0) S ACT=$TR($$FMTE^XLFDT(ACT,"5DF")," ","0")
     21 .S INACT=$P(NODE,"^",10) ;inactive date (fm)
     22 .I INACT'=""&(INACT'=0) S INACT=$TR($$FMTE^XLFDT(INACT,"5DF")," ","0")
     23 .S RNAME=$P(NODE,"^",8) ;standard role name
     24 .S UNAME=$P(NODE,"^",6) ;user class name
     25 .S PRIEN=+$P(NODE,"^") ;practitioner ien
     26 .S PRNAME=$P(NODE,"^",2) ;practitioner name
     27 .;
     28 .;Get person class information
     29 .S PCLASS=$$GET^XUA4A72(PRIEN)
     30 .F SCI=1,2,3 S PCLASS(SCI)=$P(PCLASS,U,(SCI+1))
     31 .;
     32 .S TPNODE=$G(^SCTM(404.57,+TPIEN,0))
     33 .S PCLIN=+$P(TPNODE,"^",9) ;associated clinic ien
     34 .S PCLIN=$P($G(^SC(PCLIN,0)),"^") ;associated clinic name
     35 .;
     36 .;Get preceptor
     37 .S PRCP=$P($$OKPREC2^SCMCLK(TPIEN,DT),U,2)
     38 .;
     39 .S TNODE=$G(^SCTM(404.51,TIEN,0)) ;team node
     40 .S TNAME=$P(TNODE,"^") ;team name
     41 .S TPHONE=$P(TNODE,"^",2) ;team phone
     42 .S TPC=$S($P(TNODE,"^",5)=1:"YES",1:"NO") ;primary care?
     43 .S INS=+$P(TNODE,"^",7) ;team division ien
     44 .S INAME=$P($G(^DIC(4,INS,0)),"^") ;team division name
     45 .D KTEAM(TNAME,TPHONE,TPC,INAME,TIEN,INS)
     46 .;
     47 .S OPH=$P($G(^VA(200,PRIEN,.13)),"^",2) ;office phone
     48 .S ROOM=$P($G(^VA(200,PRIEN,.14)),"^") ;room
     49 .S SERV=+$P($G(^VA(200,PRIEN,5)),"^") ;service/section ien
     50 .S SERV=$P($G(^DIC(49,SERV,0)),"^") ;service/section name
     51 .;
     52 .D FORMAT(PNAME,TPIEN,PCLIN,RNAME,UNAME,ACT,INACT,PRIEN,PRNAME,OPH,ROOM,SERV,INS,TIEN,PRCP,.PCLASS)
     53 Q
     54 ;
     55KTEAM(TNAME,TPHONE,TPC,TDIV,TIEN,IEND) ;
     56 ;store team information
     57 I TDIV="" S TDIV="[BAD DATA]"
     58 I TNAME="" S TNAME="[BDA DATA]"
     59 S @STORE@("I",TDIV,IEND)=""
     60 S @STORE@("T",IEND,TNAME,TIEN)=""
     61 S @STORE@(IEND)="Division: "_TDIV
     62 S @STORE@(IEND,TIEN,"H1")="Team Name: "_TNAME
     63 S $E(@STORE@(IEND,TIEN,"H1"),40)="Team Phone: "_TPHONE
     64 S @STORE@(IEND,TIEN,"H2")="Primary Care Team: "_TPC
     65 S @STORE@(IEND,TIEN,"H3")=""
     66 S @STORE@(IEND,TIEN,"H4")="Members:"
     67 Q
     68 ;
     69FORMAT(POS,TPIEN,PCLIN,SPOS,UCLASS,BEG,END,PIEN,PRACT,OPH,ROOM,SERV,DIV,TEM,PRCP,PCLASS) ;
     70 ;POS - position name
     71 ;TPIEN - position ien
     72 ;PCLIN - associated clinic
     73 ;SPOS - standard  position
     74 ;UCLASS - user class
     75 ;BEG - begin date
     76 ;END - end date
     77 ;PIEN - ien of new person file
     78 ;PRACT - practitioner name
     79 ;OPH - office number
     80 ;ROOM - room
     81 ;SERV - service
     82 ;DIV - ien of division
     83 ;TEM - ien of team
     84 ;PRCP - preceptor
     85 ;PCLASS - person class
     86 ;
     87 N SCI
     88 I PRACT="" S PRACT="[BAD DATA]"
     89 S @STORE@("PN",DIV,TEM,PRACT,PIEN,TPIEN)=""
     90 S @STORE@(DIV,TEM,PIEN,TPIEN,1)=PRACT
     91 S $E(@STORE@(DIV,TEM,PIEN,TPIEN,1),35)="Position: "_POS
     92 S @STORE@(DIV,TEM,PIEN,TPIEN,2)="Standard Role: "_SPOS
     93 S @STORE@(DIV,TEM,PIEN,TPIEN,3)="User Class: "_UCLASS
     94 S @STORE@(DIV,TEM,PIEN,TPIEN,4)=SERV
     95 S $E(@STORE@(DIV,TEM,PIEN,TPIEN,4),35)="Assoc Clinic: "_PCLIN
     96 S @STORE@(DIV,TEM,PIEN,TPIEN,5)="Office Phone: "_OPH
     97 S $E(@STORE@(DIV,TEM,PIEN,TPIEN,5),35)="Room: "_ROOM
     98 S @STORE@(DIV,TEM,PIEN,TPIEN,6)="Begin Date: "_BEG
     99 S $E(@STORE@(DIV,TEM,PIEN,TPIEN,6),35)="End Date: "_END
     100 S SCI=7
     101 I $L(PRCP) S @STORE@(DIV,TEM,PIEN,TPIEN,SCI)="Preceptor: "_PRCP,SCI=8
     102 I $L(PCLASS(1)) S @STORE@(DIV,TEM,PIEN,TPIEN,SCI)="Person Class: "_PCLASS(1),SCI=SCI+1
     103 I $L(PCLASS(2)) S @STORE@(DIV,TEM,PIEN,TPIEN,SCI)="                 "_PCLASS(2),SCI=SCI+1
     104 I $L(PCLASS(3)) S @STORE@(DIV,TEM,PIEN,TPIEN,SCI)="                    "_PCLASS(3)
     105 Q
     106 ;
     107NEWP(INST,TEM,TITL,PAGE,HEAD) ;
     108 ;new page
     109 D NEWP1^SCRPU3(.PAGE,TITL)
     110 D HEAD1(INST,TEM,.HEAD)
     111 Q
     112 ;
     113HEAD1(INST,TEM,HEAD) ;
     114 ;write headings
     115 W !,$G(@STORE@(INST))
     116 N NXT
     117 S NXT="H"
     118 F  S NXT=$O(@STORE@(INST,TEM,NXT)) Q:NXT'?1"H".E  D
     119 .W !,$G(@STORE@(INST,TEM,NXT))
     120 W ! ;extra line between MEMBERS and practitioner list
     121 S HEAD=1
     122 Q
     123HOLD1(PAGE,TITL,INST,TEM,HEAD) ;
     124 ;device is home, reached end of page
     125 D HOLD^SCRPU3(.PAGE,TITL)
     126 I STOP Q
     127 D HEAD1(INST,TEM,.HEAD)
     128 Q

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPTP.m

    r613 r623  
    1 SCRPTP  ;ALB/CMM - List of Team's Patients ; 29 Jun 99  04:11PM
    2         ;;5.3;Scheduling;**41,48,174,177,526,520**;AUG 13, 1993;Build 26
    3         ;
    4 PROMPTS ;Prompt for Institution, Team, Role, Patient Status and Print device
    5         N QTIME,PRNT,VAUTD,VAUTT,VAUTR,VAUTPS,NUMBER
    6         K SCUP
    7         S QTIME=""
    8         W ! D INST^SCRPU1 I Y=-1 G ERR
    9         W ! K Y D PRMTT^SCRPU1 I '$D(VAUTT) G ERR
    10         W ! K Y D ROLE^SCRPU1 I '$D(VAUTR) G ERR
    11         W ! K Y D PTSTAT^SCRPU2 I '$D(VAUTPS) G ERR
    12         W ! K Y S SORT=$$SORT2^SCRPU2()
    13         I SORT<1 G ERR
    14         W !!,"This report requires 132 column output!"
    15         D QUE(.VAUTD,.VAUTT,.VAUTR,VAUTPS,SORT) Q
    16         ;
    17 QUE(INST,TEAM,ROLE,PSTAT,SORT,IOP,ZTDTH)        ;queue report
    18         ;INST - institutions selected (variable and array)
    19         ;TEAM - teams selected (variable and array)
    20         ;ROLE - roles selected (variable and array)
    21         ;PSTAT - patient status - 1=all or OPT or AC
    22         ;SORT - 1=d,t,ptname 2=d,t,Pt ID 3=d,t,pract,pt name 4=d,t,pract,Pt ID
    23         N ZTSAVE,II
    24         F II="INST","TEAM","ROLE","ROLE(","SORT","PSTAT","INST(","TEAM(" S ZTSAVE(II)=""
    25         W ! D EN^XUTMDEVQ("QENTRY^SCRPTP","Team Patient Listing",.ZTSAVE)
    26         Q
    27         ;
    28 ENTRY2(INST,TEAM,ROLE,PSTAT,SORT,IOP,ZTDTH)     ;Second entry point for GUI to use
    29         ;INST - institutions selected (variable and array)
    30         ;TEAM - teams selected (variable and array)
    31         ;ROLE - roles selected (variable and array)
    32         ;PSTAT - patient status - 1=all or OPT or AC
    33         ;SORT - 1=d,t,ptname 2=d,t,Pt ID 3=d,t,pract,pt name 4=d,t,pract,Pt ID
    34         ;IOP - print device
    35         ;ZTDTH - queue time (optional)
    36         ;
    37         ;validate parameters
    38         I '$D(INST)!'$D(TEAM)!'$D(ROLE)!'$D(PSTAT)!'$D(SORT)!'$D(IOP)!(IOP="") Q
    39         N NUMBER
    40         S IOST=$P(IOP,"^",2),IOP=$P(IOP,"^")
    41         I IOP?1"Q;".E S IOP=$P(IOP,"Q;",2)
    42         I IOST?1"C-".E D QENTRY G RET
    43         I ZTDTH="" S ZTDTH=$H
    44         S ZTRTN="QENTRY^SCRPTP"
    45         S ZTDESC="List of Team's Patients",ZTIO=IOP
    46         N II
    47         F II="INST","TEAM","ROLE","ROLE(","SORT","PSTAT","INST(","TEAM(","IOP" S ZTSAVE(II)=""
    48         D ^%ZTLOAD
    49 RET     S NUMBER=0
    50         I $D(ZTSK) S NUMBER=ZTSK
    51         D EXIT1
    52         Q NUMBER
    53         ;
    54 QENTRY  ;driver entry point
    55         S TITL="Team Patient Listing",STORE="^TMP("_$J_",""SCRPTP"")"
    56         K @STORE
    57         S @STORE=0
    58         D FIND
    59         I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL)
    60         I '$D(NODATA) D PRINTIT^SCRPTP2(STORE,TITL)
    61         D EXIT2
    62         Q
    63 ERR     ;
    64 EXIT1   ;
    65         K ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE,SCUP
    66         Q
    67 EXIT2   ;
    68         K @STORE
    69         K STOP,STORE,TITL,IOP,TEAM,INST,ROLE,PSTAT,SORT,NODATA
    70         Q
    71 FIND    ;
    72         N TIEN,ERR,LIST,OKAY
    73         I TEAM=1 D TALL^SCRPPAT3 ;gets all teams for all divisions selected
    74         S TIEN="",LIST="^TMP("_$J_",""SCRPTP ARRAY"")",ERR="ERROR"
    75         K @LIST,@ERR
    76         F  S TIEN=$O(TEAM(TIEN)) Q:TIEN=""  D
    77         .;TIEN - team ien
    78         .S OKAY=$$PTTM^SCAPMC2(TIEN,"",LIST,ERR)
    79         .; gets all patients for given team
    80         .D HITS^SCRPTP3(LIST,TIEN)
    81         .K @LIST,@ERR
    82         K @LIST,@ERR
    83         Q
    84 TINF(TIEN)      ;team information
    85         ;TIEN - team ien
    86         ;returns: institution ien ^ team name ^ primary care ^ team phone
    87         N PC,PHONE,TNODE,TNAME
    88         S TNODE=$G(^SCTM(404.51,TIEN,0))
    89         S TNAME=$P(TNODE,"^") ;team name
    90         S PC=$S($P(TNODE,"^",5)=1:"YES",1:"NO") ;primary care team
    91         S PHONE=$P(TNODE,"^",2) ;team phone
    92         S INS=+$P(TNODE,"^",7) ;institution ien
    93         D TDESC^SCRPITP2(TIEN,INS) ;gets team description
    94         Q INS_"^"_TNAME_"^"_PC_"^"_PHONE
    95         ;
    96 PST(PTIEN,CLIEN)        ;
    97         ;PTIEN - patient ien
    98         ;CLIEN - associated clinic ien
    99         ;returns 1=selected patient status, 0=not selected patient status
    100         ;
    101         N EN,NXT,FOUND,ENODE
    102         S EN="",(FOUND,NXT)=0
    103         Q:'$D(^DPT(PTIEN,"DE","B",CLIEN)) FOUND
    104         S EN=$O(^DPT(PTIEN,"DE","B",CLIEN,""))
    105         I EN=""&(PSTAT=1) S FOUND=1 Q FOUND
    106         Q:EN=""!'$D(^DPT(PTIEN,"DE",EN,1)) FOUND
    107         F  S NXT=$O(^DPT(PTIEN,"DE",EN,1,NXT)) Q:(FOUND)!(NXT="")!(NXT'?.N)  D
    108         .;check if active enrollment
    109         .S ENODE=$G(^DPT(PTIEN,"DE",EN,1,NXT,0))
    110         .I $P(ENODE,"^",3)'="",$P(ENODE,"^",3)<DT+1!$P(ENODE,"^")>DT Q  ;not active enrollment
    111         .;                      ^ discharge date     ^ enrollment date
    112         .Q:$P(ENODE,"^",2)'=$E(PSTAT,1)&(PSTAT'=1)  ;not selected patient status
    113         .S FOUND=1
    114         Q FOUND
    115         ;
    116 FORMAT(INS,TIEN,PTIEN,PTNAME,PID,PIEN,PNAME,CNAME,PINF,ROLN,PCAP)       ;Format column information
    117         ;INS - Institution ien
    118         ;TIEN - team ien
    119         ;PTIEN - patient ien
    120         ;PTNAME - patient name
    121         ;PID - SSN
    122         ;PIEN - practitioner ien
    123         ;PNAME - practitioner name
    124         ;CNAME - clinic name
    125         ;LAST - last appointment
    126         ;NEXT - next appointment
    127         ;ROLN - role name
    128         ;PCAP - PC?
    129         ;
    130         N SEC,TRD
    131         I PNAME="" S PNAME="[BAD DATA]"
    132         I PTNAME="" S PTNAME="[BAD DATA]"
    133         I PID="" S PID="*********"
    134         S @STORE@("P",INS,TIEN,PNAME,PIEN)="" ;practitioner
    135         S @STORE@("PT",INS,TIEN,PTNAME,PTIEN)="" ;patient
    136         S @STORE@("PID",INS,TIEN,PID,PTIEN)=""
    137         I (SORT=1)!(SORT=2) S SEC=PTIEN,TRD=PIEN ;sort doesn't include practitioner
    138         I (SORT=3)!(SORT=4) S SEC=PIEN,TRD=PTIEN ;sort includes practitioner
    139         S @STORE@(INS,TIEN,SEC,TRD)=$E(PTNAME,1,15) ;patient name
    140         S $E(@STORE@(INS,TIEN,SEC,TRD),18)=PID ;9 digit pid
    141         S $E(@STORE@(INS,TIEN,SEC,TRD),32)=$E(PNAME,1,22) ;practitioner name
    142         S $E(@STORE@(INS,TIEN,SEC,TRD),56)=$E($G(ROLN),1,22) ;role name
    143         S $E(@STORE@(INS,TIEN,SEC,TRD),80)=$G(PCAP) ;PC?
    144         S $E(@STORE@(INS,TIEN,SEC,TRD),85)=$P(PINF,"^",8) ;last appointment
    145         S $E(@STORE@(INS,TIEN,SEC,TRD),97)=$P(PINF,"^",9) ;next appointment
    146         S $E(@STORE@(INS,TIEN,SEC,TRD),109)=$E(CNAME,1,24) ;clinic name
    147         Q
    148 FORMATAC(SCCNT,CNAME,PINF,INS,TIEN,PTIEN,PTNAME,PID,PIEN,PNAME,ROLN,PCAP)       ;Format MULTIPLES
    149         ;INS - Institution ien
    150         ;TIEN - team ien
    151         ;PTIEN - patient ien
    152         ;PTNAME - patient name
    153         ;PID - last 4 PID - includes pseudo notation as 5th
    154         ;PIEN - practitioner ien
    155         ;PNAME - practitioner name
    156         ;CNAME - clinic name
    157         ;LAST - last appointment
    158         ;NEXT - next appointment
    159         ;ROLN - role name
    160         ;PCAP - PC?
    161         ;
    162         N SEC,TRD
    163         I PNAME="" S PNAME="[BAD DATA]"
    164         I PTNAME="" S PTNAME="[BAD DATA]"
    165         I PID="" S PID="****"
    166         S @STORE@("P",INS,TIEN,PNAME,PIEN)="" ;practitioner
    167         S @STORE@("PT",INS,TIEN,PTNAME,PTIEN)="" ;patient
    168         S @STORE@("PID",INS,TIEN,PID,PTIEN)="" ;last 4 pid
    169         N TRD
    170         I (SORT=1)!(SORT=2) S SEC=PTIEN,TRD=PIEN ;sort doesn't include practitioner
    171         I (SORT=3)!(SORT=4) S SEC=PIEN,TRD=PTIEN ;sort includes practitioner
    172         I '$D(@STORE@(INS,TIEN,SEC,TRD,SCCNT))  D
    173         .S $E(@STORE@(INS,TIEN,SEC,TRD,SCCNT),85)=$P(PINF,"^",8) ;last appointment
    174         .S $E(@STORE@(INS,TIEN,SEC,TRD,SCCNT),97)=$P(PINF,"^",9) ;next appointment
    175         .S $E(@STORE@(INS,TIEN,SEC,TRD,SCCNT),109)=$E(CNAME,1,24) ;clinic name
    176         .Q
    177         Q
     1SCRPTP ;ALB/CMM - List of Team's Patients ; 29 Jun 99  04:11PM
     2 ;;5.3;Scheduling;**41,48,174,177**;AUG 13, 1993
     3 ;
     4PROMPTS ;Prompt for Institution, Team, Role, Patient Status and Print device
     5 N QTIME,PRNT,VAUTD,VAUTT,VAUTR,VAUTPS,NUMBER
     6 K SCUP
     7 S QTIME=""
     8 W ! D INST^SCRPU1 I Y=-1 G ERR
     9 W ! K Y D PRMTT^SCRPU1 I '$D(VAUTT) G ERR
     10 W ! K Y D ROLE^SCRPU1 I '$D(VAUTR) G ERR
     11 W ! K Y D PTSTAT^SCRPU2 I '$D(VAUTPS) G ERR
     12 W ! K Y S SORT=$$SORT2^SCRPU2()
     13 I SORT<1 G ERR
     14 W !!,"This report requires 132 column output!"
     15 D QUE(.VAUTD,.VAUTT,.VAUTR,VAUTPS,SORT) Q
     16 ;
     17QUE(INST,TEAM,ROLE,PSTAT,SORT,IOP,ZTDTH) ;queue report
     18 ;INST - institutions selected (variable and array)
     19 ;TEAM - teams selected (variable and array)
     20 ;ROLE - roles selected (variable and array)
     21 ;PSTAT - patient status - 1=all or OPT or AC
     22 ;SORT - 1=d,t,ptname 2=d,t,last 4 Pt ID 3=d,t,pract,pt name 4=d,t,pract,last 4 Pt ID
     23 N ZTSAVE,II
     24 F II="INST","TEAM","ROLE","ROLE(","SORT","PSTAT","INST(","TEAM(" S ZTSAVE(II)=""
     25 W ! D EN^XUTMDEVQ("QENTRY^SCRPTP","Team Patient Listing",.ZTSAVE)
     26 Q
     27 ;
     28ENTRY2(INST,TEAM,ROLE,PSTAT,SORT,IOP,ZTDTH) ;Second entry point for GUI to use
     29 ;INST - institutions selected (variable and array)
     30 ;TEAM - teams selected (variable and array)
     31 ;ROLE - roles selected (variable and array)
     32 ;PSTAT - patient status - 1=all or OPT or AC
     33 ;SORT - 1=d,t,ptname 2=d,t,last 4 Pt ID 3=d,t,pract,pt name 4=d,t,pract,last 4 Pt ID
     34 ;IOP - print device
     35 ;ZTDTH - queue time (optional)
     36 ;
     37 ;validate parameters
     38 I '$D(INST)!'$D(TEAM)!'$D(ROLE)!'$D(PSTAT)!'$D(SORT)!'$D(IOP)!(IOP="") Q
     39 N NUMBER
     40 S IOST=$P(IOP,"^",2),IOP=$P(IOP,"^")
     41 I IOP?1"Q;".E S IOP=$P(IOP,"Q;",2)
     42 I IOST?1"C-".E D QENTRY G RET
     43 I ZTDTH="" S ZTDTH=$H
     44 S ZTRTN="QENTRY^SCRPTP"
     45 S ZTDESC="List of Team's Patients",ZTIO=IOP
     46 N II
     47 F II="INST","TEAM","ROLE","ROLE(","SORT","PSTAT","INST(","TEAM(","IOP" S ZTSAVE(II)=""
     48 D ^%ZTLOAD
     49RET S NUMBER=0
     50 I $D(ZTSK) S NUMBER=ZTSK
     51 D EXIT1
     52 Q NUMBER
     53 ;
     54QENTRY ;driver entry point
     55 S TITL="Team Patient Listing",STORE="^TMP("_$J_",""SCRPTP"")"
     56 K @STORE
     57 S @STORE=0
     58 D FIND
     59 I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL)
     60 I '$D(NODATA) D PRINTIT^SCRPTP2(STORE,TITL)
     61 D EXIT2
     62 Q
     63ERR ;
     64EXIT1 ;
     65 K ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE,SCUP
     66 Q
     67EXIT2 ;
     68 K @STORE
     69 K STOP,STORE,TITL,IOP,TEAM,INST,ROLE,PSTAT,SORT,NODATA
     70 Q
     71FIND ;
     72 N TIEN,ERR,LIST,OKAY
     73 I TEAM=1 D TALL^SCRPPAT3 ;gets all teams for all divisions selected
     74 S TIEN="",LIST="^TMP("_$J_",""SCRPTP ARRAY"")",ERR="ERROR"
     75 K @LIST,@ERR
     76 F  S TIEN=$O(TEAM(TIEN)) Q:TIEN=""  D
     77 .;TIEN - team ien
     78 .S OKAY=$$PTTM^SCAPMC2(TIEN,"",LIST,ERR)
     79 .; gets all patients for given team
     80 .D HITS^SCRPTP3(LIST,TIEN)
     81 .K @LIST,@ERR
     82 K @LIST,@ERR
     83 Q
     84TINF(TIEN) ;team information
     85 ;TIEN - team ien
     86 ;returns: institution ien ^ team name ^ primary care ^ team phone
     87 N PC,PHONE,TNODE,TNAME
     88 S TNODE=$G(^SCTM(404.51,TIEN,0))
     89 S TNAME=$P(TNODE,"^") ;team name
     90 S PC=$S($P(TNODE,"^",5)=1:"YES",1:"NO") ;primary care team
     91 S PHONE=$P(TNODE,"^",2) ;team phone
     92 S INS=+$P(TNODE,"^",7) ;institution ien
     93 D TDESC^SCRPITP2(TIEN,INS) ;gets team description
     94 Q INS_"^"_TNAME_"^"_PC_"^"_PHONE
     95 ;
     96PST(PTIEN,CLIEN) ;
     97 ;PTIEN - patient ien
     98 ;CLIEN - associated clinic ien
     99 ;returns 1=selected patient status, 0=not selected patient status
     100 ;
     101 N EN,NXT,FOUND,ENODE
     102 S EN="",(FOUND,NXT)=0
     103 Q:'$D(^DPT(PTIEN,"DE","B",CLIEN)) FOUND
     104 S EN=$O(^DPT(PTIEN,"DE","B",CLIEN,""))
     105 I EN=""&(PSTAT=1) S FOUND=1 Q FOUND
     106 Q:EN=""!'$D(^DPT(PTIEN,"DE",EN,1)) FOUND
     107 F  S NXT=$O(^DPT(PTIEN,"DE",EN,1,NXT)) Q:(FOUND)!(NXT="")!(NXT'?.N)  D
     108 .;check if active enrollment
     109 .S ENODE=$G(^DPT(PTIEN,"DE",EN,1,NXT,0))
     110 .I $P(ENODE,"^",3)'="",$P(ENODE,"^",3)<DT+1!$P(ENODE,"^")>DT Q  ;not active enrollment
     111 .;                      ^ discharge date     ^ enrollment date
     112 .Q:$P(ENODE,"^",2)'=$E(PSTAT,1)&(PSTAT'=1)  ;not selected patient status
     113 .S FOUND=1
     114 Q FOUND
     115 ;
     116FORMAT(INS,TIEN,PTIEN,PTNAME,PID,PIEN,PNAME,CNAME,LAST,NEXT,ROLN,PCAP) ;Format column information
     117 ;INS - Institution ien
     118 ;TIEN - team ien
     119 ;PTIEN - patient ien
     120 ;PTNAME - patient name
     121 ;PID - last 4 PID - includes pseudo notation as 5th
     122 ;PIEN - practitioner ien
     123 ;PNAME - practitioner name
     124 ;CNAME - clinic name
     125 ;LAST - last appointment
     126 ;NEXT - next appointment
     127 ;ROLN - role name
     128 ;PCAP - PC?
     129 ;
     130 N SEC,TRD
     131 I PNAME="" S PNAME="[BAD DATA]"
     132 I PTNAME="" S PTNAME="[BAD DATA]"
     133 I PID="" S PID="****"
     134 S @STORE@("P",INS,TIEN,PNAME,PIEN)="" ;practitioner
     135 S @STORE@("PT",INS,TIEN,PTNAME,PTIEN)="" ;patient
     136 S @STORE@("PID",INS,TIEN,PID,PTIEN)="" ;last 4 pid
     137 N TRD
     138 I (SORT=1)!(SORT=2) S SEC=PTIEN,TRD=PIEN ;sort doesn't include practitioner
     139 I (SORT=3)!(SORT=4) S SEC=PIEN,TRD=PTIEN ;sort includes practitioner
     140 S @STORE@(INS,TIEN,SEC,TRD)=$E(PTNAME,1,22) ;patient name
     141 S $E(@STORE@(INS,TIEN,SEC,TRD),25)=PID ;last 4 pid
     142 S $E(@STORE@(INS,TIEN,SEC,TRD),32)=$E(PNAME,1,22) ;practitioner name
     143 S $E(@STORE@(INS,TIEN,SEC,TRD),56)=$E($G(ROLN),1,22) ;role name
     144 S $E(@STORE@(INS,TIEN,SEC,TRD),80)=$G(PCAP) ;PC?
     145 S $E(@STORE@(INS,TIEN,SEC,TRD),85)=LAST ;last appointment
     146 S $E(@STORE@(INS,TIEN,SEC,TRD),97)=NEXT ;next appointment
     147 S $E(@STORE@(INS,TIEN,SEC,TRD),109)=$E(CNAME,1,24) ;clinic name
     148 Q

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPTP2.m

    r613 r623  
    1 SCRPTP2 ;ALB/CMM - List of Team's Patients ; 29 Jun 99  04:11PM
    2         ;;5.3;Scheduling;**41,53,52,174,177,231,526,520**;AUG 13, 1993;Build 26
    3         ;
    4         ;List of Team's Patients Report
    5         ;
    6 TFORMAT(INST,INAME,TIEN,TNAME,PHONE,PC) ; Format team information
    7         ;INST - institution ien
    8         ;INAME - institution name
    9         ;TIEN - team ien
    10         ;TNAME - team name
    11         ;PHONE - team phone
    12         ;PC - primary care team (yes/no)
    13         ;
    14         I INAME="" S INAME="[BAD DATA]"
    15         I TNAME="" S TNAME="[BAD DATA]"
    16         S @STORE@("I",INAME,INST)=""
    17         S @STORE@("T",INST,TNAME,TIEN)=""
    18         S @STORE@(INST)="Division: "_INAME
    19         S @STORE@(INST,TIEN)="Team: "_TNAME
    20         S $E(@STORE@(INST,TIEN),45)="Team Phone: "_PHONE
    21         S @STORE@(INST,TIEN,1)="Primary Care Team: "_PC
    22         Q
    23         ;
    24 PRINTIT(STORE,TITL)     ;
    25         N INST,INAME,TNAME,TIEN
    26         S (NEW,PAGE)=1,STOP=0 W:$E(IOST)="C" @IOF
    27         D TITLE^SCRPU3(.PAGE,TITL,132) ;write title
    28         D SETH
    29         ;
    30         S INAME=""
    31         F  S INAME=$O(@STORE@("I",INAME)) Q:INAME=""!(STOP)  D
    32         .S INST=$O(@STORE@("I",INAME,""))
    33         .Q:INST=""
    34         .I ('NEW)&(IOST'?1"C-".E) D NEWP1^SCRPU3(.PAGE,TITL,132)
    35         .I ('NEW)&(IOST?1"C-".E) D HOLD^SCRPU3(.PAGE,TITL,132)
    36         .Q:STOP
    37         .W !,$G(@STORE@(INST)) ;write institution
    38         .S TNAME=""
    39         .F  S TNAME=$O(@STORE@("T",INST,TNAME)) Q:TNAME=""!(STOP)  D
    40         ..S TIEN=$O(@STORE@("T",INST,TNAME,""))
    41         ..Q:TIEN=""
    42         ..D TPRINT(INST,TIEN) ;writes team info
    43         ..Q:STOP
    44         ..;
    45         ..I (IOST'?1"C-".E)&($Y>(IOSL-4)) D NEWP1^SCRPU3(.PAGE,TITL,132)
    46         ..I (IOST?1"C-".E)&($Y>(IOSL-4)) D HOLD^SCRPU3(.PAGE,TITL,132)
    47         ..Q:STOP
    48         ..D HEADER
    49         ..I (SORT=3)!(SORT=4) D PRACT(INST,TIEN,.NEW)
    50         ..I (SORT=1)!(SORT=2) D PTP(INST,TIEN,.NEW)
    51         K NEW,PAGE
    52         I 'STOP,$E(IOST)="C" N DIR S DIR(0)="E" W ! D ^DIR
    53         Q
    54         ;
    55 PRACT(INST,TIEN,NEW)    ;Print by practitioner/patient
    56         N PNAME,PIEN,SEC2,ST1,TRD,TRDI
    57         S PNAME="",PIEN=""
    58         F  S PNAME=$O(@STORE@("P",INST,TIEN,PNAME)) Q:PNAME=""!(STOP)  D
    59         . F  S PIEN=$O(@STORE@("P",INST,TIEN,PNAME,PIEN)) Q:PIEN=""!(STOP)  D
    60         . . I (SORT=1)!(SORT=3) S SEC2="""PT""" ;sort by patient name
    61         . . I (SORT=2)!(SORT=4) S SEC2="""PID""" ;sort by last 4 PID
    62         . . S ST1=$E(STORE,1,$L(STORE)-1)_","_SEC2_")"
    63         . . I (IOST'?1"C-".E)&($Y>(IOSL-4)) D NEWP1^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER
    64         . . Q:STOP
    65         . . I (IOST?1"C-".E)&($Y>(IOSL-4)) D HOLD^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER
    66         . . Q:STOP
    67         . . S (TRDI,TRD)=""
    68         . . F  S TRD=$O(@ST1@(INST,TIEN,TRD)) Q:TRD=""!(STOP)  D
    69         . . . F  S TRDI=$O(@ST1@(INST,TIEN,TRD,TRDI)) Q:TRDI=""!(STOP)  D
    70         . . . . I (IOST'?1"C-".E)&($Y>(IOSL-4)) D NEWP1^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER
    71         . . . . Q:STOP
    72         . . . . I (IOST?1"C-".E)&($Y>(IOSL-4)) D HOLD^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER
    73         . . . . Q:STOP
    74         . . . . I $D(@STORE@(INST,TIEN,PIEN,TRDI)) W !,$G(@STORE@(INST,TIEN,PIEN,TRDI)) ;write column data
    75         . . . . N SCACL
    76         . . . . S SCACL="" F  S SCACL=$O(@STORE@(INST,TIEN,PIEN,TRDI,SCACL)) Q:SCACL=""  D
    77         . . . . . W !,$G(@STORE@(INST,TIEN,PIEN,TRDI,SCACL))
    78         . S NEW=0
    79         Q
    80         ;
    81 PTP(INST,TIEN,NEW)      ;Print by patient/practitioner
    82         N SEC2,ST1,TRDI,TRD,PNAME,PIEN
    83         I (SORT=1)!(SORT=3) S SEC2="""PT""" ;sort by patient name
    84         I (SORT=2)!(SORT=4) S SEC2="""PID""" ;sort by last 4 PID
    85         S ST1=$E(STORE,1,$L(STORE)-1)_","_SEC2_")"
    86         I (IOST'?1"C-".E)&($Y>(IOSL-4)) D NEWP1^SCRPU3(.PAGE,TITL,132)
    87         I (IOST?1"C-".E)&($Y>(IOSL-4)) D HOLD^SCRPU3(.PAGE,TITL,132)
    88         Q:STOP
    89         S (TRDI,TRD)=""
    90         F  S TRD=$O(@ST1@(INST,TIEN,TRD)) Q:TRD=""!(STOP)  D
    91         . F  S TRDI=$O(@ST1@(INST,TIEN,TRD,TRDI)) Q:TRDI=""!(STOP)  D
    92         . . I (IOST'?1"C-".E)&($Y>(IOSL-4)) D NEWP1^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER
    93         . . Q:STOP
    94         . . I (IOST?1"C-".E)&($Y>(IOSL-4)) D HOLD^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER
    95         . . Q:STOP
    96         . . S PNAME="",PIEN=""
    97         . . F  S PNAME=$O(@STORE@("P",INST,TIEN,PNAME)) Q:PNAME=""!(STOP)!(PIEN=0)  D
    98         . . . F  S PIEN=$O(@STORE@("P",INST,TIEN,PNAME,PIEN)) Q:PIEN=""!(STOP)  D
    99         . . . . I (IOST'?1"C-".E)&($Y>(IOSL-4)) D NEWP1^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER
    100         . . . . Q:STOP
    101         . . . . I (IOST?1"C-".E)&($Y>(IOSL-4)) D HOLD^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER
    102         . . . . Q:STOP
    103         . . . . I $D(@STORE@(INST,TIEN,TRDI,PIEN)) W !,$G(@STORE@(INST,TIEN,TRDI,PIEN)) ;write column data
    104         . . . . N SCACL
    105         . . . . S SCACL="" F  S SCACL=$O(@STORE@(INST,TIEN,TRDI,PIEN,SCACL)) Q:SCACL=""  D
    106         . . . . . W !,$G(@STORE@(INST,TIEN,TRDI,PIEN,SCACL))
    107         . S NEW=0
    108         Q
    109         ;
    110 TPRINT(INST,TIEN)       ;
    111         ;prints team data
    112         N NXT
    113         I (IOST'?1"C-".E)&($Y>(IOSL-13)) D NEWP1^SCRPU3(.PAGE,TITL,132) W:'STOP !,$G(@STORE@(INST))
    114         I (IOST?1"C-".E)&($Y>(IOSL-13)) D HOLD^SCRPU3(.PAGE,TITL,132) W:'STOP !,$G(@STORE@(INST))
    115         Q:STOP
    116         W !!,$G(@STORE@(INST,TIEN))
    117         S NXT=0
    118         W !,$G(@STORE@(INST,TIEN,1)) ;write team info
    119         Q:'$D(@STORE@(INST,TIEN,"D"))  W !
    120         S NXT=""
    121         ;write team description
    122         F  S NXT=$O(@STORE@(INST,TIEN,"D",NXT)) Q:NXT=""!(STOP)  D
    123         .I (IOST'?1"C-".E)&$Y>(IOSL-13) D NEWP1^SCRPU3(.PAGE,TITL,132) W:'STOP !,$G(@STORE@(INST))
    124         .I (IOST?1"C-".E)&$Y>(IOSL-13) D HOLD^SCRPU3(.PAGE,TITL,132) W:'STOP !,$G(@STORE@(INST))
    125         .Q:STOP
    126         .W !,$G(@STORE@(INST,TIEN,"D",NXT))
    127         W !!,"[Not Assigned] = Patient assigned to Team but not to a position/provider"
    128         W !,"[Inactive Position] = Patient assigned to Team & Position but has no active provider"
    129         Q
    130         ;
    131 HEADER  ;prints column headings
    132         N NXT
    133         F NXT="H1","H2","H3" D
    134         .W !,$G(@STORE@(NXT))
    135         Q
    136         ;
    137 SETH    ;sets column headings
    138         S @STORE@("H2")="Patient Name"
    139         S $E(@STORE@("H2"),18)="Pt ID"
    140         S $E(@STORE@("H2"),32)="Practitioner"
    141         S $E(@STORE@("H2"),56)="Role"
    142         S $E(@STORE@("H2"),80)="PC?"
    143         S $E(@STORE@("H1"),85)="Last"
    144         S $E(@STORE@("H2"),85)="Appt."
    145         S $E(@STORE@("H1"),97)="Next"
    146         S $E(@STORE@("H2"),97)="Appt."
    147         S $E(@STORE@("H2"),109)="Associated Clinic"
    148         S $P(@STORE@("H3"),"=",133)=""
    149         Q
     1SCRPTP2 ;ALB/CMM - List of Team's Patients ; 29 Jun 99  04:11PM
     2 ;;5.3;Scheduling;**41,53,52,174,177,231**;AUG 13, 1993
     3 ;
     4 ;List of Team's Patients Report
     5 ;
     6TFORMAT(INST,INAME,TIEN,TNAME,PHONE,PC) ; Format team information
     7 ;INST - institution ien
     8 ;INAME - institution name
     9 ;TIEN - team ien
     10 ;TNAME - team name
     11 ;PHONE - team phone
     12 ;PC - primary care team (yes/no)
     13 ;
     14 I INAME="" S INAME="[BAD DATA]"
     15 I TNAME="" S TNAME="[BAD DATA]"
     16 S @STORE@("I",INAME,INST)=""
     17 S @STORE@("T",INST,TNAME,TIEN)=""
     18 S @STORE@(INST)="Division: "_INAME
     19 S @STORE@(INST,TIEN)="Team: "_TNAME
     20 S $E(@STORE@(INST,TIEN),45)="Team Phone: "_PHONE
     21 S @STORE@(INST,TIEN,1)="Primary Care Team: "_PC
     22 Q
     23 ;
     24PRINTIT(STORE,TITL) ;
     25 N INST,INAME,TNAME,TIEN
     26 S (NEW,PAGE)=1,STOP=0 W:$E(IOST)="C" @IOF
     27 D TITLE^SCRPU3(.PAGE,TITL,132) ;write title
     28 D SETH
     29 ;
     30 S INAME=""
     31 F  S INAME=$O(@STORE@("I",INAME)) Q:INAME=""!(STOP)  D
     32 .S INST=$O(@STORE@("I",INAME,""))
     33 .Q:INST=""
     34 .I ('NEW)&(IOST'?1"C-".E) D NEWP1^SCRPU3(.PAGE,TITL,132)
     35 .I ('NEW)&(IOST?1"C-".E) D HOLD^SCRPU3(.PAGE,TITL,132)
     36 .Q:STOP
     37 .W !,$G(@STORE@(INST)) ;write institution
     38 .S TNAME=""
     39 .F  S TNAME=$O(@STORE@("T",INST,TNAME)) Q:TNAME=""!(STOP)  D
     40 ..S TIEN=$O(@STORE@("T",INST,TNAME,""))
     41 ..Q:TIEN=""
     42 ..D TPRINT(INST,TIEN) ;writes team info
     43 ..Q:STOP
     44 ..;
     45 ..I (IOST'?1"C-".E)&($Y>(IOSL-4)) D NEWP1^SCRPU3(.PAGE,TITL,132)
     46 ..I (IOST?1"C-".E)&($Y>(IOSL-4)) D HOLD^SCRPU3(.PAGE,TITL,132)
     47 ..Q:STOP
     48 ..D HEADER
     49 ..I (SORT=3)!(SORT=4) D PRACT(INST,TIEN,.NEW)
     50 ..I (SORT=1)!(SORT=2) D PTP(INST,TIEN,.NEW)
     51 K NEW,PAGE
     52 I 'STOP,$E(IOST)="C" N DIR S DIR(0)="E" W ! D ^DIR
     53 Q
     54 ;
     55PRACT(INST,TIEN,NEW) ;Print by practitioner/patient
     56 N PNAME,PIEN,SEC2,ST1,TRD,TRDI
     57 S PNAME="",PIEN=""
     58 F  S PNAME=$O(@STORE@("P",INST,TIEN,PNAME)) Q:PNAME=""!(STOP)  D
     59 . F  S PIEN=$O(@STORE@("P",INST,TIEN,PNAME,PIEN)) Q:PIEN=""!(STOP)  D
     60 . . I (SORT=1)!(SORT=3) S SEC2="""PT""" ;sort by patient name
     61 . . I (SORT=2)!(SORT=4) S SEC2="""PID""" ;sort by last 4 PID
     62 . . S ST1=$E(STORE,1,$L(STORE)-1)_","_SEC2_")"
     63 . . I (IOST'?1"C-".E)&($Y>(IOSL-4)) D NEWP1^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER
     64 . . Q:STOP
     65 . . I (IOST?1"C-".E)&($Y>(IOSL-4)) D HOLD^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER
     66 . . Q:STOP
     67 . . S (TRDI,TRD)=""
     68 . . F  S TRD=$O(@ST1@(INST,TIEN,TRD)) Q:TRD=""!(STOP)  D
     69 . . . F  S TRDI=$O(@ST1@(INST,TIEN,TRD,TRDI)) Q:TRDI=""!(STOP)  D
     70 . . . . I (IOST'?1"C-".E)&($Y>(IOSL-4)) D NEWP1^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER
     71 . . . . Q:STOP
     72 . . . . I (IOST?1"C-".E)&($Y>(IOSL-4)) D HOLD^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER
     73 . . . . Q:STOP
     74 . . . . I $D(@STORE@(INST,TIEN,PIEN,TRDI)) W !,$G(@STORE@(INST,TIEN,PIEN,TRDI)) ;write column data
     75 . S NEW=0
     76 Q
     77 ;
     78PTP(INST,TIEN,NEW) ;Print by patient/practitioner
     79 N SEC2,ST1,TRDI,TRD,PNAME,PIEN
     80 I (SORT=1)!(SORT=3) S SEC2="""PT""" ;sort by patient name
     81 I (SORT=2)!(SORT=4) S SEC2="""PID""" ;sort by last 4 PID
     82 S ST1=$E(STORE,1,$L(STORE)-1)_","_SEC2_")"
     83 I (IOST'?1"C-".E)&($Y>(IOSL-4)) D NEWP1^SCRPU3(.PAGE,TITL,132)
     84 I (IOST?1"C-".E)&($Y>(IOSL-4)) D HOLD^SCRPU3(.PAGE,TITL,132)
     85 Q:STOP
     86 S (TRDI,TRD)=""
     87 F  S TRD=$O(@ST1@(INST,TIEN,TRD)) Q:TRD=""!(STOP)  D
     88 . F  S TRDI=$O(@ST1@(INST,TIEN,TRD,TRDI)) Q:TRDI=""!(STOP)  D
     89 . . I (IOST'?1"C-".E)&($Y>(IOSL-4)) D NEWP1^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER
     90 . . Q:STOP
     91 . . I (IOST?1"C-".E)&($Y>(IOSL-4)) D HOLD^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER
     92 . . Q:STOP
     93 . . S PNAME="",PIEN=""
     94 . . F  S PNAME=$O(@STORE@("P",INST,TIEN,PNAME)) Q:PNAME=""!(STOP)!(PIEN=0)  D
     95 . . . F  S PIEN=$O(@STORE@("P",INST,TIEN,PNAME,PIEN)) Q:PIEN=""!(STOP)  D
     96 . . . . I (IOST'?1"C-".E)&($Y>(IOSL-4)) D NEWP1^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER
     97 . . . . Q:STOP
     98 . . . . I (IOST?1"C-".E)&($Y>(IOSL-4)) D HOLD^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER
     99 . . . . Q:STOP
     100 . . . . I $D(@STORE@(INST,TIEN,TRDI,PIEN)) W !,$G(@STORE@(INST,TIEN,TRDI,PIEN)) ;write column data
     101 . S NEW=0
     102 Q
     103 ;
     104TPRINT(INST,TIEN) ;
     105 ;prints team data
     106 N NXT
     107 I (IOST'?1"C-".E)&($Y>(IOSL-13)) D NEWP1^SCRPU3(.PAGE,TITL,132) W:'STOP !,$G(@STORE@(INST))
     108 I (IOST?1"C-".E)&($Y>(IOSL-13)) D HOLD^SCRPU3(.PAGE,TITL,132) W:'STOP !,$G(@STORE@(INST))
     109 Q:STOP
     110 W !!,$G(@STORE@(INST,TIEN))
     111 S NXT=0
     112 W !,$G(@STORE@(INST,TIEN,1)) ;write team info
     113 Q:'$D(@STORE@(INST,TIEN,"D"))  W !
     114 S NXT=""
     115 ;write team description
     116 F  S NXT=$O(@STORE@(INST,TIEN,"D",NXT)) Q:NXT=""!(STOP)  D
     117 .I (IOST'?1"C-".E)&$Y>(IOSL-13) D NEWP1^SCRPU3(.PAGE,TITL,132) W:'STOP !,$G(@STORE@(INST))
     118 .I (IOST?1"C-".E)&$Y>(IOSL-13) D HOLD^SCRPU3(.PAGE,TITL,132) W:'STOP !,$G(@STORE@(INST))
     119 .Q:STOP
     120 .W !,$G(@STORE@(INST,TIEN,"D",NXT))
     121 W !!,"[Not Assigned] = Patient assigned to Team but not to a position/provider"
     122 W !,"[Inactive Position] = Patient assigned to Team & Position but has no active provider"
     123 Q
     124 ;
     125HEADER ;prints column headings
     126 N NXT
     127 F NXT="H1","H2","H3" D
     128 .W !,$G(@STORE@(NXT))
     129 Q
     130 ;
     131SETH ;sets column headings
     132 S @STORE@("H2")="Patient Name"
     133 S $E(@STORE@("H2"),25)="Pt ID"
     134 S $E(@STORE@("H2"),32)="Practitioner"
     135 S $E(@STORE@("H2"),56)="Role"
     136 S $E(@STORE@("H2"),80)="PC?"
     137 S $E(@STORE@("H1"),85)="Last"
     138 S $E(@STORE@("H2"),85)="Appt."
     139 S $E(@STORE@("H1"),97)="Next"
     140 S $E(@STORE@("H2"),97)="Appt."
     141 S $E(@STORE@("H2"),109)="Associated Clinic"
     142 S $P(@STORE@("H3"),"=",133)=""
     143 Q

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPTP3.m

    r613 r623  
    1 SCRPTP3 ;ALB/CMM - List of Team's Patients ; 29 Jun 99  04:11PM
    2         ;;5.3;Scheduling;**41,48,98,177,231,433,526,520**;AUG 13, 1993;Build 26
    3         ;;DMR BP-OIFO Patch SD*5.3*526
    4         ;
    5         ;List of Team's Patients Report
    6         ;
    7 HITS(ARRY,TIEN) ;
    8         ;ARRY - list of patients for a given team
    9         ;TIEN - team ien
    10         ;
    11         N PTIEN,PIEN,PTNAME,PNAME,PTAI,NXT,NODE,CIEN,CNAME,INAME,INST,LAST,NEXT
    12         N PAIEN,PC,PHONE,PNODE,PTPA,PTPAN,ROL,PID,TINFO,TNAME,TPIEN,TPNODE
    13         N CNT,TPA,FLAG,DFN,VA,VAERR,PCAP,ROLN
    14         S INACTIVE=0
    15         S NXT=0
    16         F  S NXT=$O(@ARRY@(NXT)) Q:NXT=""!(NXT'?.N)  D
    17         .S NODE=$G(@ARRY@(NXT))
    18         .Q:NODE=""
    19         .S PTIEN=+$P(NODE,"^") ;patient ien
    20         .S PTNAME=$P(NODE,"^",2) ;patient name
    21         .S PTAI=+$P(NODE,"^",3) ;patient team assignment ien (#404.42)
    22         .;
    23         .S PNODE=$G(^DPT(PTIEN,0))
    24         .Q:PNODE=""
    25         .S DFN=PTIEN
    26         .D PID^VADPT6
    27         .;S PID=VA("BID")
    28         .S PID=$E(VA("PID"),1,3)_$E(VA("PID"),5,6)_$E(VA("PID"),8,12)
    29         .;
    30         .N CNAME,PINF,CLIEN
    31         .S CNT=""
    32         .F  S CNT=$O(^SCPT(404.43,"B",PTAI,CNT)) Q:CNT=""!(CNT'?.N)  D
    33         ..D TPAR(PTAI,CNT,.PINF,.CNAME,.CLIEN,.PNAME,.ROLN,.PCAP)
    34         Q
    35         ;
    36 TPAR(PTAI,START,PINF,CNAME,CLIEN,PNAME,ROLN,PCAP)       ;
    37         N PTPA,TPIEN,TPNODE,ROL,CIEN,ENROLL,OKAY,NEXT,LAST,PAIEN
    38         I '$D(^SCPT(404.43,"B",PTAI)) Q "0^[Not Assigned]"
    39         ; ^ no patient team position assignment
    40         IF START="" D
    41         .S PTPA=$O(^SCPT(404.43,"B",PTAI,START))
    42         ELSE  D
    43         .S PTPA=START
    44         I PTPA="" Q "0^[Not Assigned]"
    45         S PTPAN=$G(^SCPT(404.43,PTPA,0))  ;patient team assignment
    46         I PTPAN=""!(PTPAN=0) Q "0^[Not Assigned]"
    47         I $P(PTPAN,"^",4)'="",$P(PTPAN,"^",4)<DT Q -1
    48         S TPIEN=+$P(PTPAN,"^",2) ;team position ien (#404.57)
    49         I '$D(^SCTM(404.57,TPIEN,0)) Q "0^[Not Assigned]"
    50         S TPNODE=$G(^SCTM(404.57,TPIEN,0))
    51         I TPNODE="" Q "0^[Not Assigned]"
    52         S ROL=+$P(TPNODE,"^",3) ;role for position (ien)
    53         Q:'$D(ROLE(ROL))&(ROLE'=1) -1
    54         ; ^ not a selected role
    55         S ROLN=$P($G(^SD(403.46,ROL,0)),U) ;role name
    56         ;
    57         S PCAP=$S($P(PTPAN,U,5)<1:"NPC",+$$OKPREC3^SCMCLK(TPIEN,DT)>0:" AP",1:"PCP") ;PC?
    58         ;
    59         D SETASCL^SCRPRAC2(TPIEN,.CNAME,.CLIEN)
    60         ;next two lines commented off - SD*5.3*433
    61         ;S ENROLL=$$ENRL(PTIEN,CIEN) ;enrolled in associated clinic
    62         ;I 'ENROLL S CNAME="",CIEN=0
    63         ;
    64         S PAIEN=$$CHK(TPIEN)
    65         I +PAIEN'=0 S PIEN=+PAIEN,PNAME=$P(PAIEN,"^",2) ; practitioner's name
    66         ;SD*5.3*231
    67         I +PAIEN=0 S PIEN=0,PNAME="[Inactive Position]"
    68         ;
    69         D GETPINF^SCRPPAT2(PTIEN,.CLIEN,.PINF)  ;get patient info
    70         S CNAME=$G(CNAME(0))
    71         S PINF=$G(PINF(0))
    72         I PINF="" D
    73         .S PINF=PIEN_"^"_$$PDATA^SCRPEC(PIEN,CNAME,CNAME,1)
    74         I INACTIVE S @STORE@(INS,TIEN,"INACT")=""
    75         S FLAG="Y"
    76         S TINFO=$$TINF^SCRPTP(TIEN) ;team information
    77         S INST=+$P(TINFO,"^") ;institution ien
    78         S INAME=$P($G(^DIC(4,INST,0)),"^") ;institution name
    79         S PHONE=$P(TINFO,"^",4) ;team phone
    80         S PC=$P(TINFO,"^",3) ;primary care?
    81         S TNAME=$P(TINFO,"^",2) ;team name
    82         D TFORMAT^SCRPTP2(INST,INAME,TIEN,TNAME,PHONE,PC)
    83         D FORMAT^SCRPTP(INS,TIEN,PTIEN,PTNAME,PID,PIEN,PNAME,CNAME,PINF,ROLN,PCAP)
    84         N SCCNT
    85         S SCCNT=0 F  S SCCNT=$O(CNAME(SCCNT)) Q:SCCNT=""  D FORMATAC^SCRPTP(SCCNT,CNAME(SCCNT),PINF(SCCNT),INS,TIEN,PTIEN,PTNAME,PID,PIEN,PNAME,ROLN,PCAP)
    86         Q
    87         ;
    88 ENRL(PTIEN,CLIEN)       ;FUNCTIONALITY DISABLED
    89         ;
    90         ;N FOUND,ENODE,EN,NXT
    91         ;S FOUND=0
    92         ;Q:'$D(^DPT(PTIEN,"DE","B",CLIEN)) FOUND
    93         ;S EN=$O(^DPT(PTIEN,"DE","B",CLIEN,""))
    94         ;Q:EN=""!'$D(^DPT(PTIEN,"DE",EN,1)) FOUND
    95         ;S NXT=""
    96         ;F  S NXT=$O(^DPT(PTIEN,"DE",EN,1,NXT)) Q:(FOUND)!(NXT="")!(NXT'?.N)  D
    97         ;check if active enrollment
    98         ;S ENODE=$G(^DPT(PTIEN,"DE",EN,1,NXT,0))
    99         ;I $P(ENODE,"^",3)'="",$P(ENODE,"^",3)<DT+1!$P(ENODE,"^")>DT Q  ;not active enrollment
    100         ;;                      ^ discharge date     ^ enrollment date
    101         S FOUND=0
    102         Q FOUND
    103         ;
    104 CHK(TPIEN)      ;assigned to a position
    105         ;TPIEN - ien of 404.57 Team Position file
    106         ;returns:  ien of 200 New Person file
    107         N EN,PLIST,PERR,ERR,NAME
    108         S PLIST="PLST",PERR="PRR"
    109         K @PLIST,@PERR
    110         S ERR=$$PRTP^SCAPMC8(TPIEN,,.PLIST,.PERR)
    111         I '$D(@PERR) D
    112         .S EN=$P($G(@PLIST@(1)),"^") ;ien of new person file
    113         .S NAME=$P($G(@PLIST@(1)),"^",2) ; new person name
    114         K @PLIST,@PERR
    115         Q EN_"^"_NAME
    116         ;
     1SCRPTP3 ;ALB/CMM - List of Team's Patients ; 29 Jun 99  04:11PM
     2 ;;5.3;Scheduling;**41,48,98,177,231,433**;AUG 13, 1993
     3 ;
     4 ;List of Team's Patients Report
     5 ;
     6HITS(ARRY,TIEN) ;
     7 ;ARRY - list of patients for a given team
     8 ;TIEN - team ien
     9 ;
     10 N PTIEN,PIEN,PTNAME,PNAME,PTAI,NXT,NODE,CIEN,CNAME,INAME,INST,LAST,NEXT
     11 N PAIEN,PC,PHONE,PNODE,PTPA,PTPAN,ROL,PID,TINFO,TNAME,TPIEN,TPNODE
     12 N CNT,TPA,FLAG,DFN,VA,VAERR,PCAP,ROLN
     13 S INACTIVE=0
     14 S NXT=0
     15 F  S NXT=$O(@ARRY@(NXT)) Q:NXT=""!(NXT'?.N)  D
     16 .S NODE=$G(@ARRY@(NXT))
     17 .Q:NODE=""
     18 .S PTIEN=+$P(NODE,"^") ;patient ien
     19 .S PTNAME=$P(NODE,"^",2) ;patient name
     20 .S PTAI=+$P(NODE,"^",3) ;patient team assignment ien (#404.42)
     21 .;
     22 .S PNODE=$G(^DPT(PTIEN,0))
     23 .Q:PNODE=""
     24 .S DFN=PTIEN
     25 .D PID^VADPT6
     26 .S PID=VA("BID")
     27 .;
     28 .S TPA=$$TPAR(PTAI,"")
     29 .I TPA'=-1 D
     30 ..S PIEN=$P(TPA,"^")
     31 ..S PNAME=$P(TPA,"^",2)
     32 ..S CNAME=$P(TPA,"^",3)
     33 ..S LAST=$P(TPA,"^",4)
     34 ..S NEXT=$P(TPA,"^",5)
     35 ..;
     36 ..S FLAG="Y"
     37 ..S TINFO=$$TINF^SCRPTP(TIEN) ;team information
     38 ..S INST=+$P(TINFO,"^") ;institution ien
     39 ..S INAME=$P($G(^DIC(4,INST,0)),"^") ;institution name
     40 ..S PHONE=$P(TINFO,"^",4) ;team phone
     41 ..S PC=$P(TINFO,"^",3) ;primary care?
     42 ..S TNAME=$P(TINFO,"^",2) ;team name
     43 ..;
     44 ..D TFORMAT^SCRPTP2(INST,INAME,TIEN,TNAME,PHONE,PC)
     45 ..D FORMAT^SCRPTP(INST,TIEN,PTIEN,PTNAME,PID,PIEN,PNAME,CNAME,LAST,NEXT)
     46 .;
     47 .;check for other assignments
     48 .N TPIN
     49 .S CNT=""
     50 .F  S CNT=$O(^SCPT(404.43,"B",PTAI,CNT)) Q:CNT=""!(CNT'?.N)  D
     51 ..S TPIN=$$TPAR(PTAI,CNT)
     52 ..Q:TPIN=-1
     53 ..S PIEN=$P(TPIN,"^")
     54 ..S PNAME=$P(TPIN,"^",2)
     55 ..S CNAME=$P(TPIN,"^",3)
     56 ..S LAST=$P(TPIN,"^",4)
     57 ..S NEXT=$P(TPIN,"^",5)
     58 ..S ROLN=$P(TPIN,U,6)
     59 ..S PCAP=$P(TPIN,U,7)
     60 ..I '$D(FLAG) D
     61 ...S TINFO=$$TINF^SCRPTP(TIEN) ;team information
     62 ...S INST=+$P(TINFO,"^") ;institution ien
     63 ...S INAME=$P($G(^DIC(4,INST,0)),"^") ;institution name
     64 ...S PHONE=$P(TINFO,"^",4) ;team phone
     65 ...S PC=$P(TINFO,"^",3) ;primary care?
     66 ...S TNAME=$P(TINFO,"^",2) ;team name
     67 ...;
     68 ...D TFORMAT^SCRPTP2(INST,INAME,TIEN,TNAME,PHONE,PC)
     69 ..D FORMAT^SCRPTP(INST,TIEN,PTIEN,PTNAME,PID,PIEN,PNAME,CNAME,LAST,NEXT,ROLN,PCAP)
     70 I INACTIVE S @STORE@(INST,TIEN,"INACT")=""
     71 Q
     72 ;
     73TPAR(PTAI,START) ;
     74 N PTPA,TPIEN,TPNODE,ROL,CNAME,CIEN,ENROLL,OKAY,PNAME,NEXT,LAST,PAIEN
     75 N ROLN,PCAP
     76 I '$D(^SCPT(404.43,"B",PTAI)) Q "0^[Not Assigned]"
     77 ; ^ no patient team position assignment
     78 IF START="" D
     79 .S PTPA=$O(^SCPT(404.43,"B",PTAI,START))
     80 ELSE  D
     81 .S PTPA=START
     82 I PTPA="" Q "0^[Not Assigned]"
     83 S PTPAN=$G(^SCPT(404.43,PTPA,0)) ;patient team position assignment node
     84 I PTPAN=""!(PTPAN=0) Q "0^[Not Assigned]"
     85 I $P(PTPAN,"^",4)'="",$P(PTPAN,"^",4)<DT Q -1
     86 S TPIEN=+$P(PTPAN,"^",2) ;team position ien (#404.57)
     87 I '$D(^SCTM(404.57,TPIEN,0)) Q "0^[Not Assigned]"
     88 S TPNODE=$G(^SCTM(404.57,TPIEN,0))
     89 I TPNODE="" Q "0^[Not Assigned]"
     90 S ROL=+$P(TPNODE,"^",3) ;role for position (ien)
     91 Q:'$D(ROLE(ROL))&(ROLE'=1) -1
     92 ; ^ not a selected role
     93 S ROLN=$P($G(^SD(403.46,ROL,0)),U) ;role name
     94 ;
     95 S PCAP=$S($P(PTPAN,U,5)<1:"NPC",+$$OKPREC3^SCMCLK(TPIEN,DT)>0:" AP",1:"PCP") ;PC?
     96 ;
     97 S CIEN=+$P(TPNODE,"^",9) ;associated clinic ien
     98 S CNAME=$P($G(^SC(CIEN,0)),"^") ;clinic name
     99 ;check patient status
     100 S OKAY=""
     101 I CIEN>0&(PSTAT'=1) S OKAY=$$PST^SCRPTP(PTIEN,CIEN)
     102 Q:(CIEN>0)&('OKAY)&(PSTAT'=1) -1
     103 ; ^ not selected patient status
     104 ;
     105 ;next two lines commented off - SD*5.3*433
     106 ;S ENROLL=$$ENRL(PTIEN,CIEN) ;enrolled in associated clinic
     107 ;I 'ENROLL S CNAME="",CIEN=0
     108 ;
     109 S PAIEN=$$CHK(TPIEN)
     110 I +PAIEN'=0 S PIEN=+PAIEN,PNAME=$P(PAIEN,"^",2) ; practitioner's name
     111 ;SD*5.3*231
     112 I +PAIEN=0 S PIEN=0,PNAME="[Inactive Position]"
     113 ;
     114 S (NEXT,LAST)=""
     115 I +CIEN>0 S NEXT=$$GETNEXT^SCRPU3(PTIEN,CIEN) ;next appointment
     116 I +CIEN>0 S LAST=$$GETLAST^SCRPU3(PTIEN,CIEN) ;last appointment
     117 ;
     118 Q PIEN_U_PNAME_U_CNAME_U_LAST_U_NEXT_U_ROLN_U_PCAP
     119 ;
     120ENRL(PTIEN,CLIEN) ;
     121 ;
     122 N FOUND,ENODE,EN,NXT
     123 S FOUND=0
     124 Q:'$D(^DPT(PTIEN,"DE","B",CLIEN)) FOUND
     125 S EN=$O(^DPT(PTIEN,"DE","B",CLIEN,""))
     126 Q:EN=""!'$D(^DPT(PTIEN,"DE",EN,1)) FOUND
     127 S NXT=""
     128 F  S NXT=$O(^DPT(PTIEN,"DE",EN,1,NXT)) Q:(FOUND)!(NXT="")!(NXT'?.N)  D
     129 .;check if active enrollment
     130 .S ENODE=$G(^DPT(PTIEN,"DE",EN,1,NXT,0))
     131 .I $P(ENODE,"^",3)'="",$P(ENODE,"^",3)<DT+1!$P(ENODE,"^")>DT Q  ;not active enrollment
     132 .;                      ^ discharge date     ^ enrollment date
     133 .S FOUND=1
     134 Q FOUND
     135 ;
     136CHK(TPIEN) ;assigned to a position
     137 ;TPIEN - ien of 404.57 Team Position file
     138 ;returns:  ien of 200 New Person file
     139 N EN,PLIST,PERR,ERR,NAME
     140 S PLIST="PLST",PERR="PRR"
     141 K @PLIST,@PERR
     142 S ERR=$$PRTP^SCAPMC8(TPIEN,,.PLIST,.PERR)
     143 I '$D(@PERR) D
     144 .S EN=$P($G(@PLIST@(1)),"^") ;ien of new person file
     145 .S NAME=$P($G(@PLIST@(1)),"^",2) ; new person name
     146 K @PLIST,@PERR
     147 Q EN_"^"_NAME
     148 ;

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPU1.m

    r613 r623  
    1 SCRPU1  ;ALB/CMM - GENERIC PROMPTS FOR PCMM REPORTS ;1/12/96
    2         ;;5.3;Scheduling;**41,45,130,520**;AUG 13, 1993;Build 26
    3         ;
    4 INST    ;Prompt for institution
    5         S VAUTVB="VAUTD",DIC="^DIC(4,",DIC("S")="I $D(^SCTM(404.51,""AINST"",+Y))"
    6         S VAUTNI=2,VAUTSTR="Division"
    7         G FIRST^VAUTOMA
    8         ;
    9 PRMTT   ;Prompt for team.  Set VAUTTN to allow not assigned to a team as a selection
    10         I '$D(VAUTD) G ERR
    11         S VAUTVB="VAUTT",DIC="^SCTM(404.51,",VAUTNI=2,VAUTSTR="Team",DIC("B")=""
    12         S DIC("S")="I VAUTD=1!($D(VAUTD(+$P(^(0),U,7))))"
    13         G FIRST
    14         ;
    15 CLINIC  ;Prompt for Clinic
    16         I '$D(VAUTT)&'$D(VAUTCA) G ERR
    17         S VAUTVB="VAUTC",VAUTSTR="Clinic",VAUTNI=2,DIC="^SC("
    18         ;Set screen to only allow clinics and clinics that are associated to the teams selected
    19         I '$D(VAUTCA) S DIC("S")="I $$CLSC^SCRPU1()"
    20         ;VAUTCA allows for selection of any clinic in the selected
    21         I $D(VAUTCA) S DIC("S")="I $$CLSC2^SCRPU1()"
    22         G FIRST
    23         ;
    24 USER    ;Prompt for User Class
    25         I '$D(VAUTT) G ERR
    26         I $P($G(^SD(404.91,1,"PCMM")),"^")'=1 Q  ;user class turned off
    27         S VAUTVB="VAUTUC",DIC="^USR(8930,",VAUTSTR="User Class",VAUTNI=2
    28         S DIC("S")="I $$USRCL^SCRPU1"
    29         G FIRST
    30         ;
    31 USRCL() ;Screen for user class - must be related to teams selected
    32         N STOP,ENT,NODE,TIEN
    33         I '+$P(^(0),U,3) Q 0
    34         ;check for active/exiting user class
    35         S ENT=0,STOP=0
    36         F  S ENT=$O(^SCTM(404.57,"AUSR",+Y,ENT)) Q:ENT=""!(STOP)  D
    37         .S NODE=$G(^SCTM(404.57,ENT,0))
    38         .I NODE="" S STOP=0 Q
    39         .S TIEN=+$P(NODE,"^",2) ;team ien
    40         .I $D(VAUTT(TIEN))!(VAUTT=1) S STOP=1 Q
    41         .I VAUTT=""&(TIEN="") S STOP=1 Q  ;no team selected, no team assigned
    42         .I VAUTT'=1&('$D(VAUTT(TIEN))) S STOP=0
    43         Q STOP
    44         ;
    45 ROLE    ;Prompt for Role
    46         I '$D(VAUTT) G ERR
    47         S VAUTVB="VAUTR",DIC="^SD(403.46,",VAUTSTR="Role",VAUTNI=2
    48         S DIC("S")="I $$RL^SCRPU1()"
    49         G FIRST
    50         ;
    51 RL()    ;Screen for Role - screen on team
    52         N EN,STOP,ACT,TEAM
    53         S EN="",STOP=0
    54         I $D(^SCTM(404.57,"AC",+Y)) D
    55         .F  S EN=$O(^SCTM(404.57,"AC",+Y,EN)) Q:EN=""!(STOP)  D
    56         ..S ACT=+$$ACTTP^SCMCTPU(EN) ;currently active?
    57         ..I 'ACT!('$D(^SCTM(404.57,EN,0))) Q
    58         ..S TEAM=$P(^SCTM(404.57,EN,0),"^",2)
    59         ..I $D(VAUTT(TEAM))!(VAUTT=1) S STOP=1
    60         ..I VAUTT=""&(TEAM="") S STOP=1
    61         Q STOP
    62         ;
    63 PRACT   ; Prompt for One (set VAUTPO) or One,Many,All,None Practitioner(s)
    64         I '$D(VAUTT) G ERR
    65         S VAUTVB="VAUTP",VAUTSTR="Practitioner",VAUTNI=2,DIC="^VA(200,"
    66         S DIC("S")="I $$PRACS^SCRPU1()"
    67         G FIRST
    68         ;
    69 PRACS() ;Practitioner screen - off of team selection
    70         N EN,STOP,NODE,TEAM
    71         S EN="",STOP=0
    72         I '$D(^SCTM(404.52,"C",+Y)) Q 0
    73         ;Position Assignment History file
    74         F  S EN=$O(^SCTM(404.52,"C",+Y,EN)) Q:EN=""!(STOP)  D
    75         .I '$D(^SCTM(404.52,EN)) Q
    76         .S NODE=$G(^SCTM(404.52,EN,0))
    77         .S TEAM=+$P($G(^SCTM(404.57,$P(NODE,"^"),0)),"^",2)
    78         .I $P(NODE,"^",4),$D(VAUTT(TEAM)) S STOP=1
    79         .I VAUTT=1 S STOP=1
    80         Q STOP
    81         ;
    82 FIRST   ;
    83         S DIC(0)="EQMNZ",DIC("A")="Select "_VAUTSTR_": " K @VAUTVB
    84         S (@VAUTVB,Y)=0
    85 REDO    W !,DIC("A") R X:DTIME G ERR:(X="^")!'$T D:X["?"!(X=""&('$G(SCOKNULL))) HELP^SCRPU3
    86         G:$G(SCOKNULL)&(X="") QUIT
    87         I X="A"!(X="ALL")&'$D(VAUTNA) S @VAUTVB=1 G QUIT
    88         ;VAUTNA doesn't allow all to be selected
    89         ;VAUTTN allows 'Not assigned to a team' as a selection
    90         I X="N"!(X="NOT")!(X="NONE") I $D(VAUTTN)!($D(VAUTPP)) S @VAUTVB="" G QUIT
    91         ;VAUTPP allows 'Not assigned to a practitioner' as a selection
    92         S DIC("A")="Select another "_VAUTSTR_": " D ^DIC G:Y'>0 FIRST D SET
    93         I '$D(VAUTPO) F VAI=1:0:19 W !,DIC("A") R X:DTIME G ERR:(X="")!(X="^")!'$T K Y D HELP^SCRPU3:X["?" S:$E(X)="-" VAUTX=X,X=$E(VAUTX,2,999) D ^DIC I Y>0 D SET G:VAX REDO S:'VAERR VAI=VAI+1
    94         ;VAUTPO - only one practitioner allowed to be selected
    95         G QUIT
    96 SET     S VAX=0 I $D(VAUTX) S J=$S(VAUTNI=2:+Y,1:$P(Y(0),"^")) K VAUTX S VAERR=$S($D(@VAUTVB@(J)):0,1:1) W $S('VAERR:"...removed from list...",1:"...not on list...can't remove") Q:VAERR  S VAI=VAI-1 K @VAUTVB@(J) S:$O(@VAUTVB@(0))']"" VAX=1 Q
    97         S VAERR=0 I $S($D(@VAUTVB@($P(Y(0),U))):1,$D(@VAUTVB@(+Y)):1,1:0) W !?3,*7,"You have already selected that ",VAUTSTR,".  Try again." S VAERR=1
    98         S @VAUTVB@(+Y)=$P(Y(0),U)
    99         Q
    100         ;
    101 ERR     S Y=-1 I $O(@VAUTVB@(0))="" K @VAUTVB I X="^" S SCUP=""
    102 QUIT    S:'$D(Y) Y=1
    103         I $D(@VAUTVB),VAUTSTR="Team",@VAUTVB=1 D:'$G(DGQUIET) EN^DDIOL("All Teams selected, this report may take some time...","","!,?10")
    104         K DIC,J,VAERR,VAI,VAJ,VAJ1,VAX,VAUTNI,VAUTSTR,VAUTVB,X
    105         Q
    106         ;
    107 CLSC()  ;screen on clinic selection, must be related to team prompt
    108         I $P(^(0),U,3)'="C" Q 0
    109         N TRUE,EN,TEAM
    110         S TRUE=0,EN=""
    111         F  S EN=$O(^SCTM(404.57,"E",+Y,EN)) Q:EN=""!(TRUE)  D
    112         .S TEAM=+$P($G(^SCTM(404.57,EN,0)),"^",2)
    113         .I $D(VAUTT(TEAM))!(VAUTT=1) S TRUE=1
    114         I VAUTT="" S TRUE=1
    115         Q TRUE
    116         ;
    117 CLSC2() ;screen on clinic selection, must be a clinic
    118         I $P(^(0),U,3)'="C" Q 0
    119         Q 1
    120         ;
    121 CLSC2OLD()      ;screen on clinic selection, must be related to division prompt
    122         I $P(^(0),U,3)'="C" Q 0
    123         N TRUE,EN,INST,TDIV
    124         S TRUE=0,EN=""
    125         S TDIV=+$P(^(0),U,15) ;clinic's division
    126         Q:TDIV=0 0
    127         S INST=+$P(^DG(40.8,TDIV,0),U,7)
    128         I '$D(VAUTD(INST))&(VAUTD'="") S TRUE=0
    129         I $D(VAUTD(INST)) S TRUE=1
    130         I VAUTD=1 S TRUE=1
    131         Q TRUE
     1SCRPU1 ;ALB/CMM - GENERIC PROMPTS FOR PCMM REPORTS ;1/12/96
     2 ;;5.3;Scheduling;**41,45,130**;AUG 13, 1993
     3 ;
     4INST ;Prompt for institution
     5 S VAUTVB="VAUTD",DIC="^DIC(4,",DIC("S")="I $D(^SCTM(404.51,""AINST"",+Y))"
     6 S VAUTNI=2,VAUTSTR="Division"
     7 G FIRST^VAUTOMA
     8 ;
     9PRMTT ;Prompt for team.  Set VAUTTN to allow not assigned to a team as a selection
     10 I '$D(VAUTD) G ERR
     11 S VAUTVB="VAUTT",DIC="^SCTM(404.51,",VAUTNI=2,VAUTSTR="Team",DIC("B")=""
     12 S DIC("S")="I VAUTD=1!($D(VAUTD(+$P(^(0),U,7))))"
     13 G FIRST
     14 ;
     15CLINIC ;Prompt for Clinic
     16 I '$D(VAUTT)&'$D(VAUTCA) G ERR
     17 S VAUTVB="VAUTC",VAUTSTR="Clinic",VAUTNI=2,DIC="^SC("
     18 ;Set screen to only allow clinics and clinics that are associated to the teams selected
     19 I '$D(VAUTCA) S DIC("S")="I $$CLSC^SCRPU1()"
     20 ;VAUTCA allows for selection of any clinic in the selected
     21 I $D(VAUTCA) S DIC("S")="I $$CLSC2^SCRPU1()"
     22 G FIRST
     23 ;
     24USER ;Prompt for User Class
     25 I '$D(VAUTT) G ERR
     26 I $P($G(^SD(404.91,1,"PCMM")),"^")'=1 Q  ;user class turned off
     27 S VAUTVB="VAUTUC",DIC="^USR(8930,",VAUTSTR="User Class",VAUTNI=2
     28 S DIC("S")="I $$USRCL^SCRPU1"
     29 G FIRST
     30 ;
     31USRCL() ;Screen for user class - must be related to teams selected
     32 N STOP,ENT,NODE,TIEN
     33 I '+$P(^(0),U,3) Q 0
     34 ;check for active/exiting user class
     35 S ENT=0,STOP=0
     36 F  S ENT=$O(^SCTM(404.57,"AUSR",+Y,ENT)) Q:ENT=""!(STOP)  D
     37 .S NODE=$G(^SCTM(404.57,ENT,0))
     38 .I NODE="" S STOP=0 Q
     39 .S TIEN=+$P(NODE,"^",2) ;team ien
     40 .I $D(VAUTT(TIEN))!(VAUTT=1) S STOP=1 Q
     41 .I VAUTT=""&(TIEN="") S STOP=1 Q  ;no team selected, no team assigned
     42 .I VAUTT'=1&('$D(VAUTT(TIEN))) S STOP=0
     43 Q STOP
     44 ;
     45ROLE ;Prompt for Role
     46 I '$D(VAUTT) G ERR
     47 S VAUTVB="VAUTR",DIC="^SD(403.46,",VAUTSTR="Role",VAUTNI=2
     48 S DIC("S")="I $$RL^SCRPU1()"
     49 G FIRST
     50 ;
     51RL() ;Screen for Role - screen on team
     52 N EN,STOP,ACT,TEAM
     53 S EN="",STOP=0
     54 I $D(^SCTM(404.57,"AC",+Y)) D
     55 .F  S EN=$O(^SCTM(404.57,"AC",+Y,EN)) Q:EN=""!(STOP)  D
     56 ..S ACT=+$$ACTTP^SCMCTPU(EN) ;currently active?
     57 ..I 'ACT!('$D(^SCTM(404.57,EN,0))) Q
     58 ..S TEAM=$P(^SCTM(404.57,EN,0),"^",2)
     59 ..I $D(VAUTT(TEAM))!(VAUTT=1) S STOP=1
     60 ..I VAUTT=""&(TEAM="") S STOP=1
     61 Q STOP
     62 ;
     63PRACT ; Prompt for One (set VAUTPO) or One,Many,All,None Practitioner(s)
     64 I '$D(VAUTT) G ERR
     65 S VAUTVB="VAUTP",VAUTSTR="Practitioner",VAUTNI=2,DIC="^VA(200,"
     66 S DIC("S")="I $$PRACS^SCRPU1()"
     67 G FIRST
     68 ;
     69PRACS() ;Practitioner screen - off of team selection
     70 N EN,STOP,NODE,TEAM
     71 S EN="",STOP=0
     72 I '$D(^SCTM(404.52,"C",+Y)) Q 0
     73 ;Position Assignment History file
     74 F  S EN=$O(^SCTM(404.52,"C",+Y,EN)) Q:EN=""!(STOP)  D
     75 .I '$D(^SCTM(404.52,EN)) Q
     76 .S NODE=$G(^SCTM(404.52,EN,0))
     77 .S TEAM=+$P($G(^SCTM(404.57,$P(NODE,"^"),0)),"^",2)
     78 .I $P(NODE,"^",4),$D(VAUTT(TEAM)) S STOP=1
     79 .I VAUTT=1 S STOP=1
     80 Q STOP
     81 ;
     82FIRST ;
     83 S DIC(0)="EQMNZ",DIC("A")="Select "_VAUTSTR_": " K @VAUTVB
     84 S (@VAUTVB,Y)=0
     85REDO W !,DIC("A") R X:DTIME G ERR:(X="^")!'$T D:X["?"!(X=""&('$G(SCOKNULL))) HELP^SCRPU3
     86 G:$G(SCOKNULL)&(X="") QUIT
     87 I X="A"!(X="ALL")&'$D(VAUTNA) S @VAUTVB=1 G QUIT
     88 ;VAUTNA doesn't allow all to be selected
     89 ;VAUTTN allows 'Not assigned to a team' as a selection
     90 I X="N"!(X="NOT")!(X="NONE") I $D(VAUTTN)!($D(VAUTPP)) S @VAUTVB="" G QUIT
     91 ;VAUTPP allows 'Not assigned to a practitioner' as a selection
     92 S DIC("A")="Select another "_VAUTSTR_": " D ^DIC G:Y'>0 FIRST D SET
     93 I '$D(VAUTPO) F VAI=1:0:19 W !,DIC("A") R X:DTIME G ERR:(X="")!(X="^")!'$T K Y D HELP^SCRPU3:X["?" S:$E(X)="-" VAUTX=X,X=$E(VAUTX,2,999) D ^DIC I Y>0 D SET G:VAX REDO S:'VAERR VAI=VAI+1
     94 ;VAUTPO - only one practitioner allowed to be selected
     95 G QUIT
     96SET S VAX=0 I $D(VAUTX) S J=$S(VAUTNI=2:+Y,1:$P(Y(0),"^")) K VAUTX S VAERR=$S($D(@VAUTVB@(J)):0,1:1) W $S('VAERR:"...removed from list...",1:"...not on list...can't remove") Q:VAERR  S VAI=VAI-1 K @VAUTVB@(J) S:$O(@VAUTVB@(0))']"" VAX=1 Q
     97 S VAERR=0 I $S($D(@VAUTVB@($P(Y(0),U))):1,$D(@VAUTVB@(+Y)):1,1:0) W !?3,*7,"You have already selected that ",VAUTSTR,".  Try again." S VAERR=1
     98 S @VAUTVB@(+Y)=$P(Y(0),U)
     99 Q
     100 ;
     101ERR S Y=-1 I $O(@VAUTVB@(0))="" K @VAUTVB I X="^" S SCUP=""
     102QUIT S:'$D(Y) Y=1
     103 I $D(@VAUTVB),VAUTSTR="Team",@VAUTVB=1 D:'$G(DGQUIET) EN^DDIOL("All Teams selected, this report may take some time...","","!,?10")
     104 K DIC,J,VAERR,VAI,VAJ,VAJ1,VAX,VAUTNI,VAUTSTR,VAUTVB,X
     105 Q
     106 ;
     107CLSC() ;screen on clinic selection, must be related to team prompt
     108 I $P(^(0),U,3)'="C" Q 0
     109 N TRUE,EN,TEAM
     110 S TRUE=0,EN=""
     111 F  S EN=$O(^SCTM(404.57,"D",+Y,EN)) Q:EN=""!(TRUE)  D
     112 .S TEAM=+$P($G(^SCTM(404.57,EN,0)),"^",2)
     113 .I $D(VAUTT(TEAM))!(VAUTT=1) S TRUE=1
     114 I VAUTT="" S TRUE=1
     115 Q TRUE
     116 ;
     117CLSC2() ;screen on clinic selection, must be a clinic
     118 I $P(^(0),U,3)'="C" Q 0
     119 Q 1
     120 ;
     121CLSC2OLD() ;screen on clinic selection, must be related to division prompt
     122 I $P(^(0),U,3)'="C" Q 0
     123 N TRUE,EN,INST,TDIV
     124 S TRUE=0,EN=""
     125 S TDIV=+$P(^(0),U,15) ;clinic's division
     126 Q:TDIV=0 0
     127 S INST=+$P(^DG(40.8,TDIV,0),U,7)
     128 I '$D(VAUTD(INST))&(VAUTD'="") S TRUE=0
     129 I $D(VAUTD(INST)) S TRUE=1
     130 I VAUTD=1 S TRUE=1
     131 Q TRUE

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPU2.m

    r613 r623  
    1 SCRPU2  ;ALB/CMM - GENERIC PROMPTS FOR PCMM REPORTS ; 12 Jan 99  1:23 PM
    2         ;;5.3;Scheduling;**41,174,297,526,520**;AUG 13, 1993;Build 26
    3         ;
    4 DTRANG(FIRST,SECOND)    ;Date Range - begin date ^ end date => fileman format
    5         ;FIRST - first prompt (not required)
    6         ;SECOND - second prompt (not required)
    7         N BDATE,EDATE,DIROUT,DUOUT,DTOUT
    8         S EDATE=-1
    9         S DIR(0)="D^::E",DIR("B")="Today"
    10         I '$D(FIRST) S DIR("A")="Begin Date"
    11         I $D(FIRST) S DIR("A")=FIRST
    12         D ^DIR
    13         I $D(DTOUT)!(X="Today") S BDATE=$P(DT,".")
    14         I $D(DUOUT)!($D(DIROUT))  Q -1
    15         S BDATE=+Y
    16 DEN     I '$D(SECOND) S DIR("A")="End Date"
    17         I $D(SECOND) S DIR("A")=SECOND
    18         K DTOUT,X,Y
    19         D ^DIR
    20         I $D(DTOUT)!(X="Today") S EDATE=$P(DT,".")
    21         I $D(DUOUT)!($D(DIROUT)) Q -1
    22         S EDATE=+Y
    23         I EDATE<BDATE W !,"End date can't occur before Begin Date",! G DEN
    24         K X,Y,DIR
    25         Q BDATE_"^"_EDATE
    26         ;
    27 GTEAM(CLN,DFN)  ;
    28         ;given clinic and patient, find related team
    29         N TPEN,FOUND,TEAM
    30         S TPEN="",FOUND=0
    31         F  S TPEN=$O(^SCTM(404.57,"E",CLN,TPEN)) Q:TPEN=""!(FOUND)  D
    32         .S TEAM=$P(^SCTM(404.57,TPEN,0),"^",2)
    33         .I $D(^SCPT(404.42,"APTTM",DFN,TEAM)) S FOUND=1
    34         I FOUND=1 Q TEAM
    35         Q FOUND
    36         ;
    37 ASSUN   ;
    38         ;prompt for assigned or unassigned to Primary Care Team
    39         N VAUTVB
    40         S VAUTVB="VAUTA"
    41         W !,"(A)ssigned or (U)nassigned Patients to Primary Care Team: "
    42         R X:DTIME
    43         I (X="^")!'$T G ERR
    44         I (X'="A")&(X'="U") D HLP G ASSUN
    45         I (X="")!(X["?") D HLP G ASSUN
    46         I X="A" S @VAUTVB=1
    47         I X="U" S @VAUTVB=0
    48         K X
    49         Q
    50         ;
    51 PCLNHR()        ;Prompt to Print Clinic Hours
    52         S DIR("A")="Print Clinic Hours",DIR("B")="Y"
    53         Q $$YESNO()
    54         ;
    55 PCLNIN()        ;Prompt to Print Clinic Information
    56         S DIR("A")="Print Clinic Information",DIR("B")="Y"
    57         Q $$YESNO()
    58         ;
    59 SUMM()  ;Prompt to Print Summary Only (y/n)
    60         S DIR("A")="Print Summary Only",DIR("B")="N"
    61         S DIR("?")="Enter 'Y' to have patient names excluded, 'N' to include patient names"
    62         Q $$YESNO()
    63         ;
    64 YESNO() ;Yes/No prompt
    65         N X,DTOUT,DUOUT,DIROUT,Y
    66         S DIR(0)="Y"
    67         D ^DIR
    68         I $D(DTOUT)!(X="") S Y=$S(DIR("B")="Y":1,1:0)
    69         I $D(DUOUT)!($D(DIROUT)) S Y=-1
    70         K DIR
    71         Q +Y
    72         ;
    73 PTSTAT  ;Prompt for Patient Status (All, OPT, AC)
    74         ;Modified by patch 172
    75         S VAUTPS=1 Q
    76         ;
    77         N X,STAT,VAUTVB
    78         S VAUTVB="VAUTPS"
    79         W !,"Patient Status: ALL//"
    80         R X:DTIME
    81         I '$T!(X="")!(X="ALL") S @VAUTVB=1
    82         I X="^" G ERR
    83         I (X["?") D HLP2 G PTSTAT
    84         I X="A"!(X="AC") S @VAUTVB="AC"
    85         I X="O"!(X="OPT") S @VAUTVB="OPT"
    86         I '$D(@VAUTVB) D HLP2 G PTSTAT
    87         Q
    88         ;
    89 HLP2    ;help prompt for Patient Status
    90         W !,"Enter: ",!?10,"- A or AC for patients whose status is AC"
    91         W !?10,"- O or OPT for patient whose status is OPT"
    92         W !?10,"- Enter or ALL for both AC and OPT patients"
    93         Q
    94 HLP     ;
    95         ;help prompt
    96         W !,"Enter: ",!?5,"- A for patients assigned to the team as Primary Care"
    97         W !?10,"- U for patients not assigned to the team as Primary Care"
    98         Q
    99         ;
    100 ERR     S Y=-1 I $O(@VAUTVB@(0))="" K @VAUTVB
    101 QUIT    S:'$D(Y) Y=1 K DIC,J,VAERR,VAI,VAJ,VAJ1,VAX,VAUTNI,VAUTSTR,VAUTVB,X
    102         Q
    103         ;
    104 SORT()  ;
    105         ;Prompt for sorting by Division, Team, Practitioner or Division, Practitioner, Team
    106         ;
    107 EN1     N X
    108         W !,"Sort By:",!?10,"[1] Division, Team, Practitioner",!?10,"[2] Division, Practitioner, Team"
    109         W !?10,"[3] Practitioner,Associated Clinic"
    110         W !!,"Select 1 or 2 or 3: "
    111         R X:DTIME
    112         I (X="^")!'$T Q 0
    113         I (X'="1")&(X'="2")&(X'=3) D HLP3 G EN1
    114         I (X["?")!(X="") D HLP3 G EN1
    115         Q X
    116 HLP3    ;
    117         ;help prompt
    118         W !,"Enter: ",!?5,"- 1 to sort by Division, Team, Practitioner "
    119         W !?10,"- 2 to sort by Division, Practitioner, Team"
    120         Q
    121         ;
    122 SORT2() ;Prompt for sorting by:
    123         ;   [1] Division, Team, Patient Name
    124         ;or [2] Division, Team, SSN
    125         ;or [3] Division, Team, Practitioner, Patient Name
    126         ;or [4] Division, Team, Practitioner, SSN
    127         ;
    128 EN4     ;
    129         N X
    130         W !,"Sort By:",!?10,"[1] Division, Team, Patient Name"
    131         W !?10,"[2] Division, Team, SSN"
    132         W !?10,"[3] Division, Team, Practitioner, Patient Name"
    133         W !?10,"[4] Division, Team, Practitioner, SSN"
    134         W !!,"Select 1, 2, 3, or 4: "
    135         R X:DTIME
    136         I X=""!(X="^")!'$T Q 0
    137         I (X'="1")&(X'="2")&(X'="3")&(X'="4") D HLP4 G EN4
    138         I (X["?") D HLP4 G EN4
    139         Q X
    140 HLP4    ;
    141         ;help prompt
    142         W !,"Enter: ",!?5,"- 1 to sort by Division, Team, Patient Name"
    143         W !?10,"- 2 to sort by Division, Team, SSN"
    144         W !?10,"- 3 to sort by Division, Team, Practitioner, Patient Name"
    145         W !?10,"- 4 to sort by Division, Team, Practitioner, SSN"
    146         Q
     1SCRPU2 ;ALB/CMM - GENERIC PROMPTS FOR PCMM REPORTS ; 12 Jan 99  1:23 PM
     2 ;;5.3;Scheduling;**41,174,297**;AUG 13, 1993
     3 ;
     4DTRANG(FIRST,SECOND) ;Date Range - begin date ^ end date => fileman format
     5 ;FIRST - first prompt (not required)
     6 ;SECOND - second prompt (not required)
     7 N BDATE,EDATE,DIROUT,DUOUT,DTOUT
     8 S EDATE=-1
     9 S DIR(0)="D^::E",DIR("B")="Today"
     10 I '$D(FIRST) S DIR("A")="Begin Date"
     11 I $D(FIRST) S DIR("A")=FIRST
     12 D ^DIR
     13 I $D(DTOUT)!(X="Today") S BDATE=$P(DT,".")
     14 I $D(DUOUT)!($D(DIROUT))  Q -1
     15 S BDATE=+Y
     16DEN I '$D(SECOND) S DIR("A")="End Date"
     17 I $D(SECOND) S DIR("A")=SECOND
     18 K DTOUT,X,Y
     19 D ^DIR
     20 I $D(DTOUT)!(X="Today") S EDATE=$P(DT,".")
     21 I $D(DUOUT)!($D(DIROUT)) Q -1
     22 S EDATE=+Y
     23 I EDATE<BDATE W !,"End date can't occur before Begin Date",! G DEN
     24 K X,Y,DIR
     25 Q BDATE_"^"_EDATE
     26 ;
     27GTEAM(CLN,DFN) ;
     28 ;given clinic and patient, find related team
     29 N TPEN,FOUND,TEAM
     30 S TPEN="",FOUND=0
     31 F  S TPEN=$O(^SCTM(404.57,"D",CLN,TPEN)) Q:TPEN=""!(FOUND)  D
     32 .S TEAM=$P(^SCTM(404.57,TPEN,0),"^",2)
     33 .I $D(^SCPT(404.42,"APTTM",DFN,TEAM)) S FOUND=1
     34 I FOUND=1 Q TEAM
     35 Q FOUND
     36 ;
     37ASSUN ;
     38 ;prompt for assigned or unassigned to Primary Care Team
     39 N VAUTVB
     40 S VAUTVB="VAUTA"
     41 W !,"(A)ssigned or (U)nassigned Patients to Primary Care Team: "
     42 R X:DTIME
     43 I (X="^")!'$T G ERR
     44 I (X'="A")&(X'="U") D HLP G ASSUN
     45 I (X="")!(X["?") D HLP G ASSUN
     46 I X="A" S @VAUTVB=1
     47 I X="U" S @VAUTVB=0
     48 K X
     49 Q
     50 ;
     51PCLNHR() ;Prompt to Print Clinic Hours
     52 S DIR("A")="Print Clinic Hours",DIR("B")="Y"
     53 Q $$YESNO()
     54 ;
     55PCLNIN() ;Prompt to Print Clinic Information
     56 S DIR("A")="Print Clinic Information",DIR("B")="Y"
     57 Q $$YESNO()
     58 ;
     59SUMM() ;Prompt to Print Summary Only (y/n)
     60 S DIR("A")="Print Summary Only",DIR("B")="N"
     61 S DIR("?")="Enter 'Y' to have patient names excluded, 'N' to include patient names"
     62 Q $$YESNO()
     63 ;
     64YESNO() ;Yes/No prompt
     65 N X,DTOUT,DUOUT,DIROUT,Y
     66 S DIR(0)="Y"
     67 D ^DIR
     68 I $D(DTOUT)!(X="") S Y=$S(DIR("B")="Y":1,1:0)
     69 I $D(DUOUT)!($D(DIROUT)) S Y=-1
     70 K DIR
     71 Q +Y
     72 ;
     73PTSTAT ;Prompt for Patient Status (All, OPT, AC)
     74 ;Modified by patch 172
     75 S VAUTPS=1 Q
     76 ;
     77 N X,STAT,VAUTVB
     78 S VAUTVB="VAUTPS"
     79 W !,"Patient Status: ALL//"
     80 R X:DTIME
     81 I '$T!(X="")!(X="ALL") S @VAUTVB=1
     82 I X="^" G ERR
     83 I (X["?") D HLP2 G PTSTAT
     84 I X="A"!(X="AC") S @VAUTVB="AC"
     85 I X="O"!(X="OPT") S @VAUTVB="OPT"
     86 I '$D(@VAUTVB) D HLP2 G PTSTAT
     87 Q
     88 ;
     89HLP2 ;help prompt for Patient Status
     90 W !,"Enter: ",!?10,"- A or AC for patients whose status is AC"
     91 W !?10,"- O or OPT for patient whose status is OPT"
     92 W !?10,"- Enter or ALL for both AC and OPT patients"
     93 Q
     94HLP ;
     95 ;help prompt
     96 W !,"Enter: ",!?5,"- A for patients assigned to the team as Primary Care"
     97 W !?10,"- U for patients not assigned to the team as Primary Care"
     98 Q
     99 ;
     100ERR S Y=-1 I $O(@VAUTVB@(0))="" K @VAUTVB
     101QUIT S:'$D(Y) Y=1 K DIC,J,VAERR,VAI,VAJ,VAJ1,VAX,VAUTNI,VAUTSTR,VAUTVB,X
     102 Q
     103 ;
     104SORT() ;
     105 ;Prompt for sorting by Division, Team, Practitioner or Division, Practitioner, Team
     106 ;
     107EN1 N X
     108 W !,"Sort By:",!?10,"[1] Division, Team, Practitioner",!?10,"[2] Division, Practitioner, Team"
     109 W !?10,"[3] Practitioner,Associated Clinic"
     110 W !!,"Select 1 or 2 or 3: "
     111 R X:DTIME
     112 I (X="^")!'$T Q 0
     113 I (X'="1")&(X'="2")&(X'=3) D HLP3 G EN1
     114 I (X["?")!(X="") D HLP3 G EN1
     115 Q X
     116HLP3 ;
     117 ;help prompt
     118 W !,"Enter: ",!?5,"- 1 to sort by Division, Team, Practitioner "
     119 W !?10,"- 2 to sort by Division, Practitioner, Team"
     120 Q
     121 ;
     122SORT2() ;Prompt for sorting by:
     123 ;   [1] Division, Team, Patient Name
     124 ;or [2] Division, Team, Last 4 Pt ID
     125 ;or [3] Division, Team, Practitioner, Patient Name
     126 ;or [4] Division, Team, Practitioner, Last 4 Pt ID
     127 ;
     128EN4 ;
     129 N X
     130 W !,"Sort By:",!?10,"[1] Division, Team, Patient Name"
     131 W !?10,"[2] Division, Team, Last 4 Pt ID"
     132 W !?10,"[3] Division, Team, Practitioner, Patient Name"
     133 W !?10,"[4] Division, Team, Practitioner, Last 4 Pt ID"
     134 W !!,"Select 1, 2, 3, or 4: "
     135 R X:DTIME
     136 I X=""!(X="^")!'$T Q 0
     137 I (X'="1")&(X'="2")&(X'="3")&(X'="4") D HLP4 G EN4
     138 I (X["?") D HLP4 G EN4
     139 Q X
     140HLP4 ;
     141 ;help prompt
     142 W !,"Enter: ",!?5,"- 1 to sort by Division, Team, Patient Name"
     143 W !?10,"- 2 to sort by Division, Team, Last 4 Pt ID"
     144 W !?10,"- 3 to sort by Division, Team, Practitioner, Patient Name"
     145 W !?10,"- 4 to sort by Division, Team, Practitioner, Last 4 Pt ID"
     146 Q

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPW24.m

    r613 r623  
    1 SCRPW24 ;RENO/KEITH - ACRP Ad Hoc Report (cont.) ;06/19/99
    2         ;;5.3;Scheduling;**144,163,180,254,243,295,329,351,510**;AUG 13, 1993;Build 3
    3         ;06/19/99 ACS - Added CPT modifier API calls
    4         ;
    5         ;11/26/03 RLC - 329 fixes primary/secondary dx problem with report
    6         ;
    7 APAC(SDX)       ;Get all procedure codes
    8         ;K SDX N SDY,SDI D GETCPT^SDOE(SDOE,"SDY") S SDI=0 F  S SDI=$O(SDY(SDI)) Q:'SDI  S SDX=$P(SDY(SDI),U),SDX=SDX_U_$P($G(^ICPT(+SDX,0)),U)_U_$P(SDY(SDI),U,16) I $L($P(SDX,U,2)) D APOTR S SDX(SDI)=SDX
    9         D APAC^SCRPW241(.SDX)
    10         D NX Q
    11         ;
    12 APOTR   ;Transform procedure external value
    13         ;S $P(SDX,U,2)=$P(SDX,U,2)_" "_$P(^ICPT(+SDX,0),U,2) Q
    14         D APOTR^SCRPW241(.SDX)
    15         Q
    16         ;
    17 APAP(SDX)       ;Get ambulatory procedures (no E&M codes)
    18         ;K SDX N SDY,SDI D GETCPT^SDOE(SDOE,"SDY") S SDI=0 F  S SDI=$O(SDY(SDI)) Q:'SDI  S SDX=$P(SDY(SDI),U) I '$D(^IBE(357.69,"B",SDX)) S SDX=SDX_U_$P($G(^ICPT(+SDX,0)),U) I $L($P(SDX,U,2)) D APOTR S SDX(SDI)=SDX
    19         D APAP^SCRPW241(.SDX)
    20         D NX Q
    21         ;
    22 APEM(SDX)       ;Get evaluation and management codes
    23         ;K SDX N SDY,SDI D GETCPT^SDOE(SDOE,"SDY") S SDI=0 F  S SDI=$O(SDY(SDI)) Q:'SDI  S SDX=$P(SDY(SDI),U) I $D(^IBE(357.69,"B",SDX)) S SDX=SDX_U_$P($G(^ICPT(+SDX,0)),U) I $L($P(SDX,U,2)) D APOTR S SDX(SDI)=SDX
    24         D APEM^SCRPW241(.SDX)
    25         D NX Q
    26         ;
    27 CLCG(SDX)       ;Get clinic group
    28         K SDX S SDX=$P(SDOE0,U,4) I SDX S SDX=$P($G(^SC(SDX,0)),U,31) I SDX,$D(^SD(409.67,SDX)) S SDX=SDX_U_$P(^SD(409.67,SDX,0),U) S:$L($P(SDX,U,2)) SDX(1)=SDX
    29         D NX Q
    30         ;
    31 CLCN(SDX)       ;Get clinic name
    32         K SDX S SDX=$P(SDOE0,U,4) I SDX S SDX=SDX_U_$P($G(^SC(SDX,0)),U) I $L($P(SDX,U,2)) S SDX(1)=SDX
    33         D NX Q
    34         ;
    35 CLCS(SDX)       ;Get clinic service
    36         K SDX S SDX=$P(SDOE0,U,4) I SDX S SDX=$P($G(^SC(SDX,0)),U,8) D FST(.SDX,44,9) S:$L($P(SDX,U,2)) SDX(1)=SDX
    37         D NX Q
    38         ;
    39 DXAD(SDX)       ;Get all diagnoses
    40         K SDX N SDY,SDI D GETDX^SDOE(SDOE,"SDY") S SDI=0 F  S SDI=$O(SDY(SDI)) Q:'SDI  S SDX=$P(SDY(SDI),U) I SDX S SDX=SDX_U_$P($$ICDDX^ICDCODE(+SDX,+SDOE0),U,2) I $L($P(SDX,U,2)) D DXOTR S SDX(SDI)=SDX
    41         D NX Q
    42         ;
    43 DXOTR   ;Transform diagnosis external value
    44         N ENCDT
    45         S ENCDT=+$G(SDOE0)
    46         I 'ENCDT D
    47         .I '$G(SDOE) S ENCDT=$$NOW^XLFDT() Q
    48         .N SDY
    49         .D GETGEN^SDOE(SDOE,"SDY")
    50         .S ENCDT=+$G(SDY(0))
    51         .K SDY
    52         S SDX=SDX_" "_$P($$ICDDX^ICDCODE(+SDX,ENCDT),U,4) Q
    53         ;
    54 DXGS(SDX,SDZ)   ;Get GAF score
    55         K SDX N SDI,SDY S SDY=$S(SDZ="H":$P($P(SDOE0,U),"."),1:DT)_.9999,SDY=9999999-SDY,SDY=$O(^YSD(627.8,"AX5",$P(SDOE0,U,2),SDY))
    56         I SDY S SDI=$O(^YSD(627.8,"AX5",$P(SDOE0,U,2),SDY,""),-1) I SDI S SDX=+$P($G(^YSD(627.8,SDI,60)),U,3) I SDX S SDX(1)=SDX_U_SDX
    57         D NX Q
    58         ;
    59 DXGSQ(SDI)      ;Set up GAF help text
    60         S SDIRQ("?",1)="Specify a value representing the Global Assessment of Functioning (GAF) score."
    61         I SDI="H" S SDIRQ("?")="Status as of the encounter date/time is used to determine 'historical' values."
    62         I SDI="C" S SDIRQ("?")="Status as of the report run date is used to determine 'current' values."
    63         Q
    64         ;
    65 DXPD(SDX)       ;Get primary diagnosis
    66         ;K SDX N SDY,SDI D GETDX^SDOE(SDOE,"SDY") S SDI=0 F  S SDI=$O(SDY(SDI)) Q:'SDI  S SDX=$P(SDY(SDI),U) I SDX,$P(SDY(SDI),U,12)="P" S SDX=SDX_U_$P($$ICDDX^ICDCODE(+SDX),U,2) I $L($P(SDX,U,3)) D DXOTR S SDX(SDI)=SDX Q
    67         ;SD*5.3*329 fixes problem of report not working for primary dx
    68         K SDX N SDY,SDI D GETDX^SDOE(SDOE,"SDY") S SDI=0 F  S SDI=$O(SDY(SDI)) Q:'SDI  S SDX=$P(SDY(SDI),U) I SDX,$P(SDY(SDI),U,12)="P" S SDX=SDX_U_$P($$ICDDX^ICDCODE(+SDX,+SDOE0),U,2) I $L($P(SDX,U,2)) D DXOTR S SDX(SDI)=SDX
    69         D NX Q
    70         ;
    71 DXSD(SDX)       ;Get secondary diagnoses
    72         ;K SDX N SDY,SDI D GETDX^SDOE(SDOE,"SDY") S SDI=0 F  S SDI=$O(SDY(SDI)) Q:'SDI  S SDX=$P(SDY(SDI),U) I SDX,$P(SDY(SDI),U,12)'="P" S SDX=SDX_U_$P($$ICDDX^ICDCODE(+SDX),U,2) I $L($P(SDX,U,3)) D DXOTR S SDX(SDI)=SDX
    73         ;SD*5.3*329 fixes problem of report not working for secondary dx
    74         K SDX N SDY,SDI D GETDX^SDOE(SDOE,"SDY") S SDI=0 F  S SDI=$O(SDY(SDI)) Q:'SDI  S SDX=$P(SDY(SDI),U) I SDX,$P(SDY(SDI),U,12)'="P" S SDX=SDX_U_$P($$ICDDX^ICDCODE(+SDX,+SDOE0),U,2) I $L($P(SDX,U,2)) D DXOTR S SDX(SDI)=SDX
    75         D NX Q
    76         ;
    77 ENED(SDX,SDZ)   ;Get enrollment date
    78         K SDX N SDY S SDY=$$ENROL($S(SDZ="H":+SDOE0,1:DT)) I SDY S (SDX,Y)=$P(SDY,U) X ^DD("DD") S SDX(1)=SDX_U_Y
    79         D NX Q
    80         ;
    81 ENEF(SDX,SDZ)   ;Get enrollment effective date
    82         K SDX N SDY S SDY=$$ENROL($S(SDZ="H":+SDOE0,1:DT)) I SDY S (SDX,Y)=$P(SDY,U,8) X ^DD("DD") S SDX(1)=SDX_U_Y
    83         D NX Q
    84         ;
    85 ENEP(SDX,SDZ)   ;Get enrollment priority
    86         K SDX N SDY S SDY=$$ENROL($S(SDZ="H":+SDOE0,1:DT)) I SDY S SDX=$P(SDY,U,7) D FST(.SDX,27.11,.07) S:$L($P(SDX,U,2)) SDX(1)=SDX
    87         D NX Q
    88         ;
    89 ENES(SDX,SDZ)   ;Get enrollment status
    90         K SDX N SDY S SDY=$$ENROL($S(SDZ="H":+SDOE0,1:DT)) I SDY S SDX=$P(SDY,U,4),SDX=SDX_U_$$EXTERNAL^DILFD(27.11,.04,"F",SDX) S:$L($P(SDX,U,2)) SDX(1)=SDX
    91         D NX Q
    92         ;
    93 ENFR(SDX,SDZ)   ;Get enrollment facility received
    94         K SDX N SDY S SDY=$$ENROL($S(SDZ="H":+SDOE0,1:DT)) I SDY S SDX=$P(SDY,U,6) I SDX S SDX=SDX_U_$P($G(^DIC(4,SDX,0)),U) S:$L($P(SDX,U,2)) SDX(1)=SDX
    95         D NX Q
    96         ;
    97 ENSE(SDX,SDZ)   ;Get enrollment source of enrollment
    98         K SDX N SDY S SDY=$$ENROL($S(SDZ="H":+SDOE0,1:DT)) I SDY S SDX=$P(SDY,U,3) D FST(.SDX,27.11,.03) S:$L($P(SDX,U,2)) SDX(1)=SDX
    99         D NX Q
    100         ;
    101 ENQ(SDZ)        ;Set up help text for enrollment
    102         I SDZ="H" S SDIRQ("?")="Enrollment status as of the encounter date/time is used for 'historical' values."
    103         I SDZ="C" S SDIRQ("?")="Enrollment status as of the report run date is used for 'current' values."
    104         Q
    105         ;
    106 OEAT(SDX)       ;Get encounter appointment type
    107         K SDX S SDX=$P(SDOE0,U,10) I SDX S SDX=SDX_U_$P($G(^SD(409.1,SDX,0)),U) S:$L($P(SDX,U,2)) SDX(1)=SDX
    108         D NX Q
    109         ;
    110 OEDV(SDX)       ;Get encounter division
    111         K SDX S SDX=$P(SDOE0,U,11) I SDX S SDX=SDX_U_$P($G(^DG(40.8,SDX,0)),U) S:$L($P(SDX,U,2)) SDX(1)=SDX
    112         D NX Q
    113         ;
    114 OEEE(SDX)       ;Get encounter eligibility
    115         K SDX S SDX=$P(SDOE0,U,13) I SDX S SDX=SDX_U_$P($G(^DIC(8,SDX,0)),U) S:$L($P(SDX,U,2)) SDX(1)=SDX
    116         D NX Q
    117         ;
    118 OEOP(SDX)       ;Get encounter originating process type
    119         K SDX S SDX=$P(SDOE0,U,8) D FST(.SDX,409.68,.08) S:$L($P(SDX,U,2)) SDX(1)=SDX
    120         D NX Q
    121         ;
    122 OEPA(SDX)       ;Get encounter patient
    123         K SDX S DFN=$P(SDOE0,U,2) I DFN D DEM^VADPT I $L(VADM(1)) S SDX(1)=DFN_U_VADM(1)
    124         D NX Q
    125         ;
    126 OEES(SDX)       ;Get encounter status
    127         K SDX S SDX=$P(SDOE0,U,12) I SDX S SDX=SDX_U_$P($G(^SD(409.63,SDX,0)),U) S:$L($P(SDX,U,2)) SDX(1)=SDX
    128         D NX Q
    129         ;
    130 OETS(SDX)       ;Get transmission status
    131         K SDX S SDX(1)=$$STX^SCRPW8(SDOE,SDOE0) Q
    132         ;
    133 TSQ(DIR)        ;Set up DIR array for transmission status question
    134         K DIR S DIR("A")="Select transmission status",DIR("?")="This value represents the transmission status of the encounter record."
    135         S DIR(0)="SO^0:Not checked-out;1:No transmission record;2:Not required, not transmitted;3:Rejected for transmission;4:Awaiting transmission;5:Transmitted, no acknowledgment;6:Transmitted, rejected;7:Transmitted, error;8:Transmitted, accepted"
    136         Q
    137         ;
    138 CLQ(DIR,SDZ)    ;Set up DIR array for classification questions
    139         K DIR S SDZ=$S(SDZ="A":"Agent Orange exposure",SDZ="I":"ionizing radiation exposure",SDZ="S":"service connected condition",1:"environmental contaminants exposure")
    140         S DIR(0)="SO^1:YES;0:NO",DIR("A")="Treatment related to "_SDZ,DIR("?")="Indicates if treatment was related to "_SDZ Q
    141         ;
    142 OECL(SDX,SDZ)   ;Get classification values
    143         K SDX N SDY S SDZ=$S(SDZ="A":1,SDZ="I":2,SDZ="S":3,SDZ="E":4,1:"") I SDZ D CLASK^SDCO2(SDOE,.SDY) S SDX=$P($G(SDY(SDZ)),U,2) I $L(SDX) S SDX(1)=$S(SDX=1:"1^YES",1:"0^NO")
    144         D NX Q
    145         ;
    146 OEOU(SDX)       ;Get option used to create
    147         K SDX S SDX=+$P(SDOE0,U,5),SDX=+$P($G(^AUPNVSIT(SDX,0)),U,24)
    148         N SDY D GETS^DIQ(19,SDX,.01,"","SDY")
    149         S SDX=SDX_U_SDY(19,SDX_",",.01) S:$L($P(SDX,U,2)) SDX(1)=SDX
    150         D NX Q
    151         ;
    152 SUQ(DIR)        ;Set up DIR() array for Scheduled/unscheduled question
    153         K DIR S DIR("A")="Select outpatient activity type",DIR("?",1)="Only pre-scheduled appointments will be reflected as SCHEDULED.  All other",DIR("?",2)="types of activity (add/edits, registrations, walkins or unscheduled activity)"
    154         S DIR("?")="will be reflected as UNSCHEDULED.",DIR(0)="SO^S:SCHEDULED;U:UNSCHEDULED" Q
    155         ;
    156 OESU(SDX)       ;Get scheduled/unscheduled status
    157         N SDAP0 K SDX S SDX(1)=""
    158         I $P(SDOE0,U,8)=1 D  Q:$L(SDX(1))
    159         .S SDAP0=$G(^DPT(+$P(SDOE0,U,2),"S",+SDOE0,0))
    160         .Q:$P(SDAP0,U,20)'=SDOE  Q:$P(SDAP0,U,7)=4
    161         .S SDX(1)="S^SCHEDULED" Q
    162         S SDX(1)="U^UNSCHEDULED" Q
    163         ;
    164 PCPR(SDX,SDZ)   ;Get primary care provider
    165         ;Required input: SDZ="C" for current, "H" for historical
    166         K SDX S SDX=$S(SDZ="C":$$OUTPTPR^SDUTL3(+$P(SDOE0,U,2)),1:$$OUTPTPR^SDUTL3(+$P(SDOE0,U,2),+$P(SDOE0,U))) S:$L($P(SDX,U,2)) SDX(1)=SDX
    167         D NX Q
    168         ;
    169 PCTM(SDX,SDZ)   ;Get priamry care team
    170         ;Required input: SDZ="C" for current, "H" for historical
    171         K SDX S SDX=$S(SDZ="C":$$OUTPTTM^SDUTL3(+$P(SDOE0,U,2)),1:$$OUTPTTM^SDUTL3(+$P(SDOE0,U,2),+$P(SDOE0,U))) S:$L($P(SDX,U,2)) SDX(1)=SDX
    172         D NX Q
    173         ;
    174 PDPA(SDX)       ;Get patient age
    175         K SDX S DFN=$P(SDOE0,U,2) I DFN D DEM^VADPT I VADM(4)=+VADM(4) S SDX(1)=VADM(4)_U_VADM(4)
    176         D NX Q
    177         ;
    178 PDPS(SDX)       ;Get patient sex
    179         K SDX S DFN=$P(SDOE0,U,2) I DFN D DEM^VADPT I $L($P(VADM(5),U,2)) S SDX(1)=VADM(5)
    180         D NX Q
    181         ;
    182 PDSC(SDX)       ;Get patient state/county
    183         K SDX S DFN=$P(SDOE0,U,2) I DFN D ADD^VADPT I $L($P(VAPA(7),U,2)) S SDX(1)=$P(VAPA(5),U)_";"_$P(VAPA(7),U)_U_$P(VAPA(5),U,2)_" / "_$P(VAPA(7),U,2)
    184         D NX Q
    185         ;
    186 PDZC(SDX)       ;Get patient zip code
    187         K SDX S DFN=$P(SDOE0,U,2) I DFN D ADD^VADPT I $L(VAPA(6)) S SDX(1)=VAPA(6)_U_VAPA(6)
    188         D NX Q
    189         ;
    190 ENROL(SDATE)    ;Get enrollment record (most recent to encounter date)
    191         N SDY,SDI,X1,X2,X,%Y S:SDATE#1=0 SDATE=SDATE+.9999 S SDI=0 F  S SDI=$O(^DGEN(27.11,"C",+$P(SDOE0,U,2),SDI)) Q:'SDI  S SDY=$G(^DGEN(27.11,SDI,0)),SDY($P($P(^DGEN(27.11,SDI,"U"),U,1),".",1))=SDY  ;SD/510 changed logic to use date/time entered
    192         S SDI=$O(SDY(SDATE),-1) Q:'SDI ""  S X1=$P($P(SDOE0,U),"."),X2=SDI D ^%DTC Q SDY(SDI)
    193         ;
    194 NX      S:$D(SDX)<10 SDX(1)="~~~NONE~~~^~~~NONE~~~" Q
    195         ;
    196 FST(SDX,SDFI,SDFE)      ;Field set transform
    197         Q:'$L(SDX)  N SDY,SDI D FIELD^DID(SDFI,SDFE,"","POINTER","SDY") S SDY=SDY("POINTER") F SDI=1:1:$L(SDY,";") I SDX=$P($P(SDY,";",SDI),":") S SDX=SDX_U_$P($P(SDY,";",SDI),":",2) Q
    198         Q
     1SCRPW24 ;RENO/KEITH - ACRP Ad Hoc Report (cont.) ;06/19/99
     2 ;;5.3;Scheduling;**144,163,180,254,243,295,329,351**;AUG 13, 1993
     3 ;06/19/99 ACS - Added CPT modifier API calls
     4 ;
     5 ;11/26/03 RLC - 329 fixes primary/secondary dx problem with report
     6 ;
     7APAC(SDX) ;Get all procedure codes
     8 ;K SDX N SDY,SDI D GETCPT^SDOE(SDOE,"SDY") S SDI=0 F  S SDI=$O(SDY(SDI)) Q:'SDI  S SDX=$P(SDY(SDI),U),SDX=SDX_U_$P($G(^ICPT(+SDX,0)),U)_U_$P(SDY(SDI),U,16) I $L($P(SDX,U,2)) D APOTR S SDX(SDI)=SDX
     9 D APAC^SCRPW241(.SDX)
     10 D NX Q
     11 ;
     12APOTR ;Transform procedure external value
     13 ;S $P(SDX,U,2)=$P(SDX,U,2)_" "_$P(^ICPT(+SDX,0),U,2) Q
     14 D APOTR^SCRPW241(.SDX)
     15 Q
     16 ;
     17APAP(SDX) ;Get ambulatory procedures (no E&M codes)
     18 ;K SDX N SDY,SDI D GETCPT^SDOE(SDOE,"SDY") S SDI=0 F  S SDI=$O(SDY(SDI)) Q:'SDI  S SDX=$P(SDY(SDI),U) I '$D(^IBE(357.69,"B",SDX)) S SDX=SDX_U_$P($G(^ICPT(+SDX,0)),U) I $L($P(SDX,U,2)) D APOTR S SDX(SDI)=SDX
     19 D APAP^SCRPW241(.SDX)
     20 D NX Q
     21 ;
     22APEM(SDX) ;Get evaluation and management codes
     23 ;K SDX N SDY,SDI D GETCPT^SDOE(SDOE,"SDY") S SDI=0 F  S SDI=$O(SDY(SDI)) Q:'SDI  S SDX=$P(SDY(SDI),U) I $D(^IBE(357.69,"B",SDX)) S SDX=SDX_U_$P($G(^ICPT(+SDX,0)),U) I $L($P(SDX,U,2)) D APOTR S SDX(SDI)=SDX
     24 D APEM^SCRPW241(.SDX)
     25 D NX Q
     26 ;
     27CLCG(SDX) ;Get clinic group
     28 K SDX S SDX=$P(SDOE0,U,4) I SDX S SDX=$P($G(^SC(SDX,0)),U,31) I SDX,$D(^SD(409.67,SDX)) S SDX=SDX_U_$P(^SD(409.67,SDX,0),U) S:$L($P(SDX,U,2)) SDX(1)=SDX
     29 D NX Q
     30 ;
     31CLCN(SDX) ;Get clinic name
     32 K SDX S SDX=$P(SDOE0,U,4) I SDX S SDX=SDX_U_$P($G(^SC(SDX,0)),U) I $L($P(SDX,U,2)) S SDX(1)=SDX
     33 D NX Q
     34 ;
     35CLCS(SDX) ;Get clinic service
     36 K SDX S SDX=$P(SDOE0,U,4) I SDX S SDX=$P($G(^SC(SDX,0)),U,8) D FST(.SDX,44,9) S:$L($P(SDX,U,2)) SDX(1)=SDX
     37 D NX Q
     38 ;
     39DXAD(SDX) ;Get all diagnoses
     40 K SDX N SDY,SDI D GETDX^SDOE(SDOE,"SDY") S SDI=0 F  S SDI=$O(SDY(SDI)) Q:'SDI  S SDX=$P(SDY(SDI),U) I SDX S SDX=SDX_U_$P($$ICDDX^ICDCODE(+SDX,+SDOE0),U,2) I $L($P(SDX,U,2)) D DXOTR S SDX(SDI)=SDX
     41 D NX Q
     42 ;
     43DXOTR ;Transform diagnosis external value
     44 N ENCDT
     45 S ENCDT=+$G(SDOE0)
     46 I 'ENCDT D
     47 .I '$G(SDOE) S ENCDT=$$NOW^XLFDT() Q
     48 .N SDY
     49 .D GETGEN^SDOE(SDOE,"SDY")
     50 .S ENCDT=+$G(SDY(0))
     51 .K SDY
     52 S SDX=SDX_" "_$P($$ICDDX^ICDCODE(+SDX,ENCDT),U,4) Q
     53 ;
     54DXGS(SDX,SDZ) ;Get GAF score
     55 K SDX N SDI,SDY S SDY=$S(SDZ="H":$P($P(SDOE0,U),"."),1:DT)_.9999,SDY=9999999-SDY,SDY=$O(^YSD(627.8,"AX5",$P(SDOE0,U,2),SDY))
     56 I SDY S SDI=$O(^YSD(627.8,"AX5",$P(SDOE0,U,2),SDY,""),-1) I SDI S SDX=+$P($G(^YSD(627.8,SDI,60)),U,3) I SDX S SDX(1)=SDX_U_SDX
     57 D NX Q
     58 ;
     59DXGSQ(SDI) ;Set up GAF help text
     60 S SDIRQ("?",1)="Specify a value representing the Global Assessment of Functioning (GAF) score."
     61 I SDI="H" S SDIRQ("?")="Status as of the encounter date/time is used to determine 'historical' values."
     62 I SDI="C" S SDIRQ("?")="Status as of the report run date is used to determine 'current' values."
     63 Q
     64 ;
     65DXPD(SDX) ;Get primary diagnosis
     66 ;K SDX N SDY,SDI D GETDX^SDOE(SDOE,"SDY") S SDI=0 F  S SDI=$O(SDY(SDI)) Q:'SDI  S SDX=$P(SDY(SDI),U) I SDX,$P(SDY(SDI),U,12)="P" S SDX=SDX_U_$P($$ICDDX^ICDCODE(+SDX),U,2) I $L($P(SDX,U,3)) D DXOTR S SDX(SDI)=SDX Q
     67 ;SD*5.3*329 fixes problem of report not working for primary dx
     68 K SDX N SDY,SDI D GETDX^SDOE(SDOE,"SDY") S SDI=0 F  S SDI=$O(SDY(SDI)) Q:'SDI  S SDX=$P(SDY(SDI),U) I SDX,$P(SDY(SDI),U,12)="P" S SDX=SDX_U_$P($$ICDDX^ICDCODE(+SDX,+SDOE0),U,2) I $L($P(SDX,U,2)) D DXOTR S SDX(SDI)=SDX
     69 D NX Q
     70 ;
     71DXSD(SDX) ;Get secondary diagnoses
     72 ;K SDX N SDY,SDI D GETDX^SDOE(SDOE,"SDY") S SDI=0 F  S SDI=$O(SDY(SDI)) Q:'SDI  S SDX=$P(SDY(SDI),U) I SDX,$P(SDY(SDI),U,12)'="P" S SDX=SDX_U_$P($$ICDDX^ICDCODE(+SDX),U,2) I $L($P(SDX,U,3)) D DXOTR S SDX(SDI)=SDX
     73 ;SD*5.3*329 fixes problem of report not working for secondary dx
     74 K SDX N SDY,SDI D GETDX^SDOE(SDOE,"SDY") S SDI=0 F  S SDI=$O(SDY(SDI)) Q:'SDI  S SDX=$P(SDY(SDI),U) I SDX,$P(SDY(SDI),U,12)'="P" S SDX=SDX_U_$P($$ICDDX^ICDCODE(+SDX,+SDOE0),U,2) I $L($P(SDX,U,2)) D DXOTR S SDX(SDI)=SDX
     75 D NX Q
     76 ;
     77ENED(SDX,SDZ) ;Get enrollment date
     78 K SDX N SDY S SDY=$$ENROL($S(SDZ="H":+SDOE0,1:DT)) I SDY S (SDX,Y)=$P(SDY,U) X ^DD("DD") S SDX(1)=SDX_U_Y
     79 D NX Q
     80 ;
     81ENEF(SDX,SDZ) ;Get enrollment effective date
     82 K SDX N SDY S SDY=$$ENROL($S(SDZ="H":+SDOE0,1:DT)) I SDY S (SDX,Y)=$P(SDY,U,8) X ^DD("DD") S SDX(1)=SDX_U_Y
     83 D NX Q
     84 ;
     85ENEP(SDX,SDZ) ;Get enrollment priority
     86 K SDX N SDY S SDY=$$ENROL($S(SDZ="H":+SDOE0,1:DT)) I SDY S SDX=$P(SDY,U,7) D FST(.SDX,27.11,.07) S:$L($P(SDX,U,2)) SDX(1)=SDX
     87 D NX Q
     88 ;
     89ENES(SDX,SDZ) ;Get enrollment status
     90 K SDX N SDY S SDY=$$ENROL($S(SDZ="H":+SDOE0,1:DT)) I SDY S SDX=$P(SDY,U,4),SDX=SDX_U_$$EXTERNAL^DILFD(27.11,.04,"F",SDX) S:$L($P(SDX,U,2)) SDX(1)=SDX
     91 D NX Q
     92 ;
     93ENFR(SDX,SDZ) ;Get enrollment facility received
     94 K SDX N SDY S SDY=$$ENROL($S(SDZ="H":+SDOE0,1:DT)) I SDY S SDX=$P(SDY,U,6) I SDX S SDX=SDX_U_$P($G(^DIC(4,SDX,0)),U) S:$L($P(SDX,U,2)) SDX(1)=SDX
     95 D NX Q
     96 ;
     97ENSE(SDX,SDZ) ;Get enrollment source of enrollment
     98 K SDX N SDY S SDY=$$ENROL($S(SDZ="H":+SDOE0,1:DT)) I SDY S SDX=$P(SDY,U,3) D FST(.SDX,27.11,.03) S:$L($P(SDX,U,2)) SDX(1)=SDX
     99 D NX Q
     100 ;
     101ENQ(SDZ) ;Set up help text for enrollment
     102 I SDZ="H" S SDIRQ("?")="Enrollment status as of the encounter date/time is used for 'historical' values."
     103 I SDZ="C" S SDIRQ("?")="Enrollment status as of the report run date is used for 'current' values."
     104 Q
     105 ;
     106OEAT(SDX) ;Get encounter appointment type
     107 K SDX S SDX=$P(SDOE0,U,10) I SDX S SDX=SDX_U_$P($G(^SD(409.1,SDX,0)),U) S:$L($P(SDX,U,2)) SDX(1)=SDX
     108 D NX Q
     109 ;
     110OEDV(SDX) ;Get encounter division
     111 K SDX S SDX=$P(SDOE0,U,11) I SDX S SDX=SDX_U_$P($G(^DG(40.8,SDX,0)),U) S:$L($P(SDX,U,2)) SDX(1)=SDX
     112 D NX Q
     113 ;
     114OEEE(SDX) ;Get encounter eligibility
     115 K SDX S SDX=$P(SDOE0,U,13) I SDX S SDX=SDX_U_$P($G(^DIC(8,SDX,0)),U) S:$L($P(SDX,U,2)) SDX(1)=SDX
     116 D NX Q
     117 ;
     118OEOP(SDX) ;Get encounter originating process type
     119 K SDX S SDX=$P(SDOE0,U,8) D FST(.SDX,409.68,.08) S:$L($P(SDX,U,2)) SDX(1)=SDX
     120 D NX Q
     121 ;
     122OEPA(SDX) ;Get encounter patient
     123 K SDX S DFN=$P(SDOE0,U,2) I DFN D DEM^VADPT I $L(VADM(1)) S SDX(1)=DFN_U_VADM(1)
     124 D NX Q
     125 ;
     126OEES(SDX) ;Get encounter status
     127 K SDX S SDX=$P(SDOE0,U,12) I SDX S SDX=SDX_U_$P($G(^SD(409.63,SDX,0)),U) S:$L($P(SDX,U,2)) SDX(1)=SDX
     128 D NX Q
     129 ;
     130OETS(SDX) ;Get transmission status
     131 K SDX S SDX(1)=$$STX^SCRPW8(SDOE,SDOE0) Q
     132 ;
     133TSQ(DIR) ;Set up DIR array for transmission status question
     134 K DIR S DIR("A")="Select transmission status",DIR("?")="This value represents the transmission status of the encounter record."
     135 S DIR(0)="SO^0:Not checked-out;1:No transmission record;2:Not required, not transmitted;3:Rejected for transmission;4:Awaiting transmission;5:Transmitted, no acknowledgment;6:Transmitted, rejected;7:Transmitted, error;8:Transmitted, accepted"
     136 Q
     137 ;
     138CLQ(DIR,SDZ) ;Set up DIR array for classification questions
     139 K DIR S SDZ=$S(SDZ="A":"Agent Orange exposure",SDZ="I":"ionizing radiation exposure",SDZ="S":"service connected condition",1:"environmental contaminants exposure")
     140 S DIR(0)="SO^1:YES;0:NO",DIR("A")="Treatment related to "_SDZ,DIR("?")="Indicates if treatment was related to "_SDZ Q
     141 ;
     142OECL(SDX,SDZ) ;Get classification values
     143 K SDX N SDY S SDZ=$S(SDZ="A":1,SDZ="I":2,SDZ="S":3,SDZ="E":4,1:"") I SDZ D CLASK^SDCO2(SDOE,.SDY) S SDX=$P($G(SDY(SDZ)),U,2) I $L(SDX) S SDX(1)=$S(SDX=1:"1^YES",1:"0^NO")
     144 D NX Q
     145 ;
     146OEOU(SDX) ;Get option used to create
     147 K SDX S SDX=+$P(SDOE0,U,5),SDX=+$P($G(^AUPNVSIT(SDX,0)),U,24)
     148 N SDY D GETS^DIQ(19,SDX,.01,"","SDY")
     149 S SDX=SDX_U_SDY(19,SDX_",",.01) S:$L($P(SDX,U,2)) SDX(1)=SDX
     150 D NX Q
     151 ;
     152SUQ(DIR) ;Set up DIR() array for Scheduled/unscheduled question
     153 K DIR S DIR("A")="Select outpatient activity type",DIR("?",1)="Only pre-scheduled appointments will be reflected as SCHEDULED.  All other",DIR("?",2)="types of activity (add/edits, registrations, walkins or unscheduled activity)"
     154 S DIR("?")="will be reflected as UNSCHEDULED.",DIR(0)="SO^S:SCHEDULED;U:UNSCHEDULED" Q
     155 ;
     156OESU(SDX) ;Get scheduled/unscheduled status
     157 N SDAP0 K SDX S SDX(1)=""
     158 I $P(SDOE0,U,8)=1 D  Q:$L(SDX(1))
     159 .S SDAP0=$G(^DPT(+$P(SDOE0,U,2),"S",+SDOE0,0))
     160 .Q:$P(SDAP0,U,20)'=SDOE  Q:$P(SDAP0,U,7)=4
     161 .S SDX(1)="S^SCHEDULED" Q
     162 S SDX(1)="U^UNSCHEDULED" Q
     163 ;
     164PCPR(SDX,SDZ) ;Get primary care provider
     165 ;Required input: SDZ="C" for current, "H" for historical
     166 K SDX S SDX=$S(SDZ="C":$$OUTPTPR^SDUTL3(+$P(SDOE0,U,2)),1:$$OUTPTPR^SDUTL3(+$P(SDOE0,U,2),+$P(SDOE0,U))) S:$L($P(SDX,U,2)) SDX(1)=SDX
     167 D NX Q
     168 ;
     169PCTM(SDX,SDZ) ;Get priamry care team
     170 ;Required input: SDZ="C" for current, "H" for historical
     171 K SDX S SDX=$S(SDZ="C":$$OUTPTTM^SDUTL3(+$P(SDOE0,U,2)),1:$$OUTPTTM^SDUTL3(+$P(SDOE0,U,2),+$P(SDOE0,U))) S:$L($P(SDX,U,2)) SDX(1)=SDX
     172 D NX Q
     173 ;
     174PDPA(SDX) ;Get patient age
     175 K SDX S DFN=$P(SDOE0,U,2) I DFN D DEM^VADPT I VADM(4)=+VADM(4) S SDX(1)=VADM(4)_U_VADM(4)
     176 D NX Q
     177 ;
     178PDPS(SDX) ;Get patient sex
     179 K SDX S DFN=$P(SDOE0,U,2) I DFN D DEM^VADPT I $L($P(VADM(5),U,2)) S SDX(1)=VADM(5)
     180 D NX Q
     181 ;
     182PDSC(SDX) ;Get patient state/county
     183 K SDX S DFN=$P(SDOE0,U,2) I DFN D ADD^VADPT I $L($P(VAPA(7),U,2)) S SDX(1)=$P(VAPA(5),U)_";"_$P(VAPA(7),U)_U_$P(VAPA(5),U,2)_" / "_$P(VAPA(7),U,2)
     184 D NX Q
     185 ;
     186PDZC(SDX) ;Get patient zip code
     187 K SDX S DFN=$P(SDOE0,U,2) I DFN D ADD^VADPT I $L(VAPA(6)) S SDX(1)=VAPA(6)_U_VAPA(6)
     188 D NX Q
     189 ;
     190ENROL(SDATE)  ;Get enrollment record (most recent to encounter date)
     191 N SDY,SDI,X1,X2,X,%Y S:SDATE#1=0 SDATE=SDATE+.9999 S SDI=0 F  S SDI=$O(^DGEN(27.11,"C",+$P(SDOE0,U,2),SDI)) Q:'SDI  S SDY=$G(^DGEN(27.11,SDI,0)),SDY(+SDY)=SDY
     192 S SDI=$O(SDY(SDATE),-1) Q:'SDI ""  S X1=$P($P(SDOE0,U),"."),X2=SDI D ^%DTC Q SDY(SDI)
     193 ;
     194NX S:$D(SDX)<10 SDX(1)="~~~NONE~~~^~~~NONE~~~" Q
     195 ;
     196FST(SDX,SDFI,SDFE) ;Field set transform
     197 Q:'$L(SDX)  N SDY,SDI D FIELD^DID(SDFI,SDFE,"","POINTER","SDY") S SDY=SDY("POINTER") F SDI=1:1:$L(SDY,";") I SDX=$P($P(SDY,";",SDI),":") S SDX=SDX_U_$P($P(SDY,";",SDI),":",2) Q
     198 Q

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPW6.m

    r613 r623  
    1 SCRPW6  ;RENO/KEITH - Trend of Facility Uniques by 12 Month Date Ranges ; 15 Jul 98  02:38PM
    2         ;;5.3;Scheduling;**139,144,466,510**;AUG 13, 1993;Build 3
    3         N SDDIV,SDI,SDSTA,DIR D TITL^SCRPW50("Trend of Facility Uniques by 12 Month Date Ranges") G:'$$DIVA^SCRPW17(.SDDIV) EXIT
    4         D SUBT^SCRPW50("**** Status Selection ****")
    5         S DIR(0)="S^1:Checked Out (Outpatients);2:Checked Out (Inpatients);3:Checked Out (Out/Inpatients)",DIR("A")="Select Status",DIR("B")="1"
    6         D ^DIR I $D(DTOUT)!$D(DUOUT)!(+Y<0) G EXIT
    7         S SDSTA=$S(Y=1:2,Y=2:8,1:"2^8")
    8 QUE     W !!,"This report requires 132 column output.",!
    9         N ZTSAVE F X="SDDIV","SDDIV(","SDDNU(","SDSTA" S ZTSAVE(X)=""
    10         D EN^XUTMDEVQ("UNIQ^SCRPW6","Trend Facility Uniques",.ZTSAVE),DISP0^SCRPW23 Q
    11 UNIQ    ;Calculate/print uniques
    12         S (SDOUT,SDSTOP)=0,SDLINE="",SDPAGE=1,$P(SDLINE,"-",133)="" D NOW^%DTC S Y=% X ^DD("DD") S SDPNOW=$P(Y,":",1,2),SDMD=$O(SDDIV(0)),SDMD=$O(SDDIV(SDMD)) S:$P(SDDIV,U,2)="ALL DIVISIONS" SDMD=1
    13         K ^TMP("SCRPW",$J) S SDBDT=$E(DT,1,3)-5_$E(DT,4,5)_"00",SDEDT=$E(DT,1,5)_"00",SDXEDT=$E(DT,1,3)-1_$E(DT,4,5)_"00" D OENC G:SDOUT EXIT
    14         S SDIV="" F  S SDIV=$O(^TMP("SCRPW",$J,SDIV)) Q:SDIV=""  D STOP Q:SDOUT  D
    15         .S SDDT=SDBDT,SDXDT=$$YDTINC(SDDT),^TMP("SCRPW",$J,SDIV,"YR","MAX")=0 D LOOK
    16         .F  S SDDT=$$DTINC(SDDT) Q:SDDT>SDXEDT  S SDXDT=$$YDTINC(SDDT) D LOOK I ^TMP("SCRPW",$J,SDIV,"YR",SDDT)>^TMP("SCRPW",$J,SDIV,"YR","MAX") S ^TMP("SCRPW",$J,SDIV,"YR","MAX")=^TMP("SCRPW",$J,SDIV,"YR",SDDT)
    17         G:SDOUT EXIT D:$E(IOST)="C" DISP0^SCRPW23 I '$D(^TMP("SCRPW",$J)) D HDR G:SDOUT EXIT S SDX="No activity found within selected report parameters!" W !!?(IOM-$L(SDX)\2),SDX G EXIT
    18         I $P(SDDIV,U,2)="SELECTED DIVISIONS" D
    19         .S SDI=0 F  S SDI=$O(SDDIV(SDI)) Q:'SDI  S SDIV(SDDIV(SDI))=SDI
    20         .Q
    21         I $P(SDDIV,U,2)="ALL DIVISIONS" D
    22         .S SDI=0 F  S SDI=$O(^TMP("SCRPW",$J,SDI)) Q:'SDI  S SDX=$P($G(^DG(40.8,SDI,0)),U) S:'$L(SDX) SDX="***UNKNOWN***" S SDIV(SDX)=SDI
    23         .Q
    24         S:$D(SDIV)'>1 SDIV($P(SDDIV,U,2))=$P(SDDIV,U,3)
    25         G:SDOUT EXIT D:$E(IOST)="C" DISP0^SCRPW23 S SDIVN="" F  S SDIVN=$O(SDIV(SDIVN)) Q:SDIVN=""!SDOUT  S SDIV=SDIV(SDIVN) D DPRT(.SDIV)
    26         G:SDOUT EXIT S SDMD=0,SDMD=$O(^TMP("SCRPW",$J,SDMD)),SDMD=$O(^TMP("SCRPW",$J,SDMD)) I SDMD S SDIV=0 D DPRT(.SDIV)
    27         I $E(IOST)="C",'SDOUT W ! N DIR S DIR(0)="E" D ^DIR
    28         ;
    29 EXIT    K SDIV,SDIVN,SDMD,SDOUT,SDSTOP,SDDIV,SDBDT,SDCT,SDDFN,SDDT,SDEDT,SDFIG,SDI,SDLINE,SDMAX,SDMO,SDOE,SDOE0,SDPAGE,SDPNOW,SDXDT,SDXEDT,SDXMO,SDXYR,SDYR,Y,%,SDX,SDFIG1,DTOUT,DUOUT,X,Y D END^SCRPW50 Q
    30         ;
    31 DPRT(SDIV)      ;Print division
    32         K SDTIT D DHDR^SCRPW46(SDIV,1,.SDTIT) I '$D(^TMP("SCRPW",$J,SDIV)) S SDX="No activity within report parameters found for this division!" D HDR Q:SDOUT  W !!?(IOM-$L(SDX)\2),SDX Q
    33         S SDDT=SDBDT D FIG,HDR,HD1 Q:SDOUT  D LINE(SDDT) F  S SDDT=$O(^TMP("SCRPW",$J,SDIV,"YR",SDDT)) Q:'SDDT!SDOUT  D LINE(SDDT)
    34         D:$Y>($S(IOSL<80:IOSL,1:80)-5) HDR Q:SDOUT  F  W ! Q:$Y>($S(IOSL<80:IOSL,1:80)-6)
    35         W !?25,"Uniques in this report are based on OUTPATIENT ENCOUNTER file records with a"
    36         W !?25,"status of '"_$S(SDSTA=2:"",SDSTA=8:"inpatient appointment ",1:"Out/Inpatient ")_"checked out'.  This excludes any 'action required' activity."
    37         Q
    38         ;
    39 DIV(SDD)        ;Check division
    40         ;Required input: MEDICAL CENTER DIVISION pointer
    41         Q:'SDDIV 1
    42         Q $D(SDDIV(SDD))
    43         ;
    44 SET(SDIV)       ;Set TMP global
    45         S SDSTOP=SDSTOP+1 D:SDSTOP#2000=0 STOP Q:SDOUT
    46         Q:'SDIV  D SET1(SDIV) D:SDMD SET1(0) Q
    47         ;
    48 SET1(SDIV)      S ^TMP("SCRPW",$J,SDIV,"PT",SDDFN,$E(SDDT,1,5)_"00")="" Q
    49         ;
    50 OENC    S SDXDT=SDBDT,SDDFN=0
    51         F  S SDDFN=$O(^SCE("ADFN",SDDFN)) Q:'SDDFN  S SDDT=SDXDT F  S SDDT=$O(^SCE("ADFN",SDDFN,SDDT)) Q:'SDDT!(SDDT>SDEDT)  D OENC1
    52         Q
    53         ;
    54 OENC1   S SDOE=0 F  S SDOE=$O(^SCE("ADFN",SDDFN,SDDT,SDOE)) Q:'SDOE  S SDOE0=$$GETOE^SDOE(SDOE) I $$OE(SDOE0,SDSTA) S SDIV=$P(SDOE0,U,11) I SDIV,$$DIV(SDIV) D SET(SDIV)
    55         Q
    56         ;
    57 OE(SDOE0,SDSTA) ;Evaluate (in)outpatient encounter
    58         ;Required input: SDOE0=OUTPATIENT ENCOUNTER zeroeth node
    59         ;                SDSTA=2 -outpatient,8 -inpatient, 2^8 -both
    60         ;Output: '1' if checked out "parent" encounter, '0' otherwise
    61         I $P(SDOE0,U,4),$P($G(^SC($P(SDOE0,U,4),0)),U,17)="Y" Q 0
    62         S SDSTA=$G(SDSTA,2),SDSTA="^"_SDSTA_"^"
    63         Q:'$P(SDOE0,U,6)&(SDSTA[$P(SDOE0,U,12))&($P(SDOE0,U,7)'="") 1
    64         Q 0
    65         ;
    66 STOP    ;Check for stop task request
    67         S:$G(ZTQUEUED) (SDOUT,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q
    68         ;
    69 HDR     D STOP Q:SDOUT  I $E(IOST)="C" N DIR S DIR(0)="E" D ^DIR S SDOUT=Y'=1 Q:SDOUT
    70         W:SDPAGE>1!($E(IOST)="C") $$XY^SCRPW50(IOF,1,0) W:$X $$XY^SCRPW50("",0,0) W SDLINE,!?36,"<*>  TREND OF FACILITY UNIQUES BY 12 MONTH DATE RANGES  <*>"
    71         N SDI S SDI=$S(SDSTA=2:"Checked Out - Outpatients",SDSTA=8:"Checked Out - Inpatients",1:"Checked Out - Out/Inpatients") W !,?53,SDI ;?(132-SDI\2),SDI
    72         S SDI=0 F  S SDI=$O(SDTIT(SDI)) Q:'SDI  W !?(132-$L(SDTIT(SDI))\2),SDTIT(SDI)
    73         W !,SDLINE,!,"Date printed: ",SDPNOW,?125,"Page: ",SDPAGE,!,SDLINE S SDPAGE=SDPAGE+1 Q
    74         ;
    75 HD1     Q:SDOUT  W !!,"12 mo. date range",?23,"Uniques",?32,"| Histogram (each ""*"" equals ",SDFIG," unique",$S(SDFIG=1:"",1:"s"),")",!,$E(SDLINE,1,SDFIG1) Q
    76         ;
    77 DTINC(SDDT)     ;Increment date by one month
    78         ;Required input: SDDT=date
    79         ;Output: next month to examine
    80         Q:$E(SDDT,4,5)=12 $E(SDDT,1,3)+1_"0100"
    81         Q $E(SDDT,1,5)+1_"00"
    82         ;
    83 LOOK    S ^TMP("SCRPW",$J,SDIV,"YR",SDDT)=0,SDDFN=0 F  S SDDFN=$O(^TMP("SCRPW",$J,SDIV,"PT",SDDFN)) Q:'SDDFN  D L1
    84         Q
    85         ;
    86 L1      I $D(^TMP("SCRPW",$J,SDIV,"PT",SDDFN,SDDT)) D LSET Q
    87         S SDX=$O(^TMP("SCRPW",$J,SDIV,"PT",SDDFN,SDDT)) I SDX,SDX<SDXDT D LSET
    88         Q
    89         ;
    90 LSET    S ^TMP("SCRPW",$J,SDIV,"YR",SDDT)=^TMP("SCRPW",$J,SDIV,"YR",SDDT)+1 Q
    91         ;
    92 YDTINC(SDDT)    ;Increment date by one year
    93         ;Required input: SDDT=date
    94         ;Output: date + 1 year
    95         Q $E(SDDT,1,3)+1_$E(SDDT,4,7)
    96         ;
    97 FIG     S SDMAX=^TMP("SCRPW",$J,SDIV,"YR","MAX") F SDFIG=1,10,25,50,100,250,500,1000,2500,5000,10000 Q:SDMAX/SDFIG<99
    98         S SDFIG1=34+(SDMAX\SDFIG) S:SDFIG1<73 SDFIG1=73 Q
    99         ;
    100 LINE(SDDT)      ;Print statistics line
    101         ;Required input: SDDT=date
    102         D:$Y>(IOSL-3) HDR,HD1 Q:SDOUT  S SDCT=^TMP("SCRPW",$J,SDIV,"YR",SDDT),SDMO=$E(SDDT,4,5),SDYR=(17+$E(SDDT))_$E(SDDT,2,3),SDXMO=SDMO-1 S:SDXMO=0 SDXMO=12 S:$L(SDXMO)=1 SDXMO=0_SDXMO
    103         S SDXYR=$S(SDXMO=12:SDYR,1:SDYR+1)
    104         W !,SDMO,"/",SDYR," thru ",SDXMO,"/",SDXYR,?24,$J(SDCT,6,0),?32,"| " F SDI=1:1:(SDCT\SDFIG) W "*"
    105         Q
     1SCRPW6 ;RENO/KEITH - Trend of Facility Uniques by 12 Month Date Ranges ; 15 Jul 98  02:38PM
     2 ;;5.3;Scheduling;**139,144,466**;AUG 13, 1993;Build 2
     3 N SDDIV,SDI,SDSTA,DIR D TITL^SCRPW50("Trend of Facility Uniques by 12 Month Date Ranges") G:'$$DIVA^SCRPW17(.SDDIV) EXIT
     4 D SUBT^SCRPW50("**** Status Selection ****")
     5 S DIR(0)="S^1:Checked Out (Outpatients);2:Checked Out (Inpatients);3:Checked Out (Out/Inpatients)",DIR("A")="Select Status",DIR("B")="1"
     6 D ^DIR I $D(DTOUT)!$D(DUOUT)!(+Y<0) G EXIT
     7 S SDSTA=$S(Y=1:2,Y=2:8,1:"2^8")
     8QUE W !!,"This report requires 132 column output.",!
     9 N ZTSAVE F X="SDDIV","SDDIV(","SDDNU(",SDSTA S ZTSAVE(X)=""
     10 D EN^XUTMDEVQ("UNIQ^SCRPW6","Trend Facility Uniques",.ZTSAVE),DISP0^SCRPW23 Q
     11UNIQ ;Calculate/print uniques
     12 S (SDOUT,SDSTOP)=0,SDLINE="",SDPAGE=1,$P(SDLINE,"-",133)="" D NOW^%DTC S Y=% X ^DD("DD") S SDPNOW=$P(Y,":",1,2),SDMD=$O(SDDIV(0)),SDMD=$O(SDDIV(SDMD)) S:$P(SDDIV,U,2)="ALL DIVISIONS" SDMD=1
     13 K ^TMP("SCRPW",$J) S SDBDT=$E(DT,1,3)-5_$E(DT,4,5)_"00",SDEDT=$E(DT,1,5)_"00",SDXEDT=$E(DT,1,3)-1_$E(DT,4,5)_"00" D OENC G:SDOUT EXIT
     14 S SDIV="" F  S SDIV=$O(^TMP("SCRPW",$J,SDIV)) Q:SDIV=""  D STOP Q:SDOUT  D
     15 .S SDDT=SDBDT,SDXDT=$$YDTINC(SDDT),^TMP("SCRPW",$J,SDIV,"YR","MAX")=0 D LOOK
     16 .F  S SDDT=$$DTINC(SDDT) Q:SDDT>SDXEDT  S SDXDT=$$YDTINC(SDDT) D LOOK I ^TMP("SCRPW",$J,SDIV,"YR",SDDT)>^TMP("SCRPW",$J,SDIV,"YR","MAX") S ^TMP("SCRPW",$J,SDIV,"YR","MAX")=^TMP("SCRPW",$J,SDIV,"YR",SDDT)
     17 G:SDOUT EXIT D:$E(IOST)="C" DISP0^SCRPW23 I '$D(^TMP("SCRPW",$J)) D HDR G:SDOUT EXIT S SDX="No activity found within selected report parameters!" W !!?(IOM-$L(SDX)\2),SDX G EXIT
     18 I $P(SDDIV,U,2)="SELECTED DIVISIONS" D
     19 .S SDI=0 F  S SDI=$O(SDDIV(SDI)) Q:'SDI  S SDIV(SDDIV(SDI))=SDI
     20 .Q
     21 I $P(SDDIV,U,2)="ALL DIVISIONS" D
     22 .S SDI=0 F  S SDI=$O(^TMP("SCRPW",$J,SDI)) Q:'SDI  S SDX=$P($G(^DG(40.8,SDI,0)),U) S:'$L(SDX) SDX="***UNKNOWN***" S SDIV(SDX)=SDI
     23 .Q
     24 S:$D(SDIV)'>1 SDIV($P(SDDIV,U,2))=$P(SDDIV,U,3)
     25 G:SDOUT EXIT D:$E(IOST)="C" DISP0^SCRPW23 S SDIVN="" F  S SDIVN=$O(SDIV(SDIVN)) Q:SDIVN=""!SDOUT  S SDIV=SDIV(SDIVN) D DPRT(.SDIV)
     26 G:SDOUT EXIT S SDMD=0,SDMD=$O(^TMP("SCRPW",$J,SDMD)),SDMD=$O(^TMP("SCRPW",$J,SDMD)) I SDMD S SDIV=0 D DPRT(.SDIV)
     27 I $E(IOST)="C",'SDOUT W ! N DIR S DIR(0)="E" D ^DIR
     28 ;
     29EXIT K SDIV,SDIVN,SDMD,SDOUT,SDSTOP,SDDIV,SDBDT,SDCT,SDDFN,SDDT,SDEDT,SDFIG,SDI,SDLINE,SDMAX,SDMO,SDOE,SDOE0,SDPAGE,SDPNOW,SDXDT,SDXEDT,SDXMO,SDXYR,SDYR,Y,%,SDX,SDFIG1,DTOUT,DUOUT,X,Y D END^SCRPW50 Q
     30 ;
     31DPRT(SDIV) ;Print division
     32 K SDTIT D DHDR^SCRPW46(SDIV,1,.SDTIT) I '$D(^TMP("SCRPW",$J,SDIV)) S SDX="No activity within report parameters found for this division!" D HDR Q:SDOUT  W !!?(IOM-$L(SDX)\2),SDX Q
     33 S SDDT=SDBDT D FIG,HDR,HD1 Q:SDOUT  D LINE(SDDT) F  S SDDT=$O(^TMP("SCRPW",$J,SDIV,"YR",SDDT)) Q:'SDDT!SDOUT  D LINE(SDDT)
     34 D:$Y>($S(IOSL<80:IOSL,1:80)-5) HDR Q:SDOUT  F  W ! Q:$Y>($S(IOSL<80:IOSL,1:80)-6)
     35 W !?25,"Uniques in this report are based on OUTPATIENT ENCOUNTER file records with a"
     36 W !?25,"status of '"_$S(SDSTA=2:"",SDSTA=8:"inpatient appointment ",1:"Out/Inpatient ")_"checked out'.  This excludes any 'action required' activity."
     37 Q
     38 ;
     39DIV(SDD) ;Check division
     40 ;Required input: MEDICAL CENTER DIVISION pointer
     41 Q:'SDDIV 1
     42 Q $D(SDDIV(SDD))
     43 ;
     44SET(SDIV) ;Set TMP global
     45 S SDSTOP=SDSTOP+1 D:SDSTOP#2000=0 STOP Q:SDOUT
     46 Q:'SDIV  D SET1(SDIV) D:SDMD SET1(0) Q
     47 ;
     48SET1(SDIV) S ^TMP("SCRPW",$J,SDIV,"PT",SDDFN,$E(SDDT,1,5)_"00")="" Q
     49 ;
     50OENC S SDXDT=SDBDT,SDDFN=0
     51 F  S SDDFN=$O(^SCE("ADFN",SDDFN)) Q:'SDDFN  S SDDT=SDXDT F  S SDDT=$O(^SCE("ADFN",SDDFN,SDDT)) Q:'SDDT!(SDDT>SDEDT)  D OENC1
     52 Q
     53 ;
     54OENC1 S SDOE=0 F  S SDOE=$O(^SCE("ADFN",SDDFN,SDDT,SDOE)) Q:'SDOE  S SDOE0=$$GETOE^SDOE(SDOE) I $$OE(SDOE0,SDSTA) S SDIV=$P(SDOE0,U,11) I SDIV,$$DIV(SDIV) D SET(SDIV)
     55 Q
     56 ;
     57OE(SDOE0,SDSTA) ;Evaluate (in)outpatient encounter
     58 ;Required input: SDOE0=OUTPATIENT ENCOUNTER zeroeth node
     59 ;                SDSTA=2 -outpatient,8 -inpatient, 2^8 -both
     60 ;Output: '1' if checked out "parent" encounter, '0' otherwise
     61 I $P(SDOE0,U,4),$P($G(^SC($P(SDOE0,U,4),0)),U,17)="Y" Q 0
     62 S SDSTA=$G(SDSTA,2),SDSTA="^"_SDSTA_"^"
     63 Q:'$P(SDOE0,U,6)&(SDSTA[$P(SDOE0,U,12))&($P(SDOE0,U,7)'="") 1
     64 Q 0
     65 ;
     66STOP ;Check for stop task request
     67 S:$G(ZTQUEUED) (SDOUT,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q
     68 ;
     69HDR D STOP Q:SDOUT  I $E(IOST)="C" N DIR S DIR(0)="E" D ^DIR S SDOUT=Y'=1 Q:SDOUT
     70 W:SDPAGE>1!($E(IOST)="C") $$XY^SCRPW50(IOF,1,0) W:$X $$XY^SCRPW50("",0,0) W SDLINE,!?36,"<*>  TREND OF FACILITY UNIQUES BY 12 MONTH DATE RANGES  <*>"
     71 N SDI S SDI=$S(SDSTA=2:"Checked Out - Outpatients",SDSTA=8:"Checked Out - Inpatients",1:"Checked Out - Out/Inpatients") W !,?53,SDI ;?(132-SDI\2),SDI
     72 S SDI=0 F  S SDI=$O(SDTIT(SDI)) Q:'SDI  W !?(132-$L(SDTIT(SDI))\2),SDTIT(SDI)
     73 W !,SDLINE,!,"Date printed: ",SDPNOW,?125,"Page: ",SDPAGE,!,SDLINE S SDPAGE=SDPAGE+1 Q
     74 ;
     75HD1 Q:SDOUT  W !!,"12 mo. date range",?23,"Uniques",?32,"| Histogram (each ""*"" equals ",SDFIG," unique",$S(SDFIG=1:"",1:"s"),")",!,$E(SDLINE,1,SDFIG1) Q
     76 ;
     77DTINC(SDDT) ;Increment date by one month
     78 ;Required input: SDDT=date
     79 ;Output: next month to examine
     80 Q:$E(SDDT,4,5)=12 $E(SDDT,1,3)+1_"0100"
     81 Q $E(SDDT,1,5)+1_"00"
     82 ;
     83LOOK S ^TMP("SCRPW",$J,SDIV,"YR",SDDT)=0,SDDFN=0 F  S SDDFN=$O(^TMP("SCRPW",$J,SDIV,"PT",SDDFN)) Q:'SDDFN  D L1
     84 Q
     85 ;
     86L1 I $D(^TMP("SCRPW",$J,SDIV,"PT",SDDFN,SDDT)) D LSET Q
     87 S SDX=$O(^TMP("SCRPW",$J,SDIV,"PT",SDDFN,SDDT)) I SDX,SDX<SDXDT D LSET
     88 Q
     89 ;
     90LSET S ^TMP("SCRPW",$J,SDIV,"YR",SDDT)=^TMP("SCRPW",$J,SDIV,"YR",SDDT)+1 Q
     91 ;
     92YDTINC(SDDT) ;Increment date by one year
     93 ;Required input: SDDT=date
     94 ;Output: date + 1 year
     95 Q $E(SDDT,1,3)+1_$E(SDDT,4,7)
     96 ;
     97FIG S SDMAX=^TMP("SCRPW",$J,SDIV,"YR","MAX") F SDFIG=1,10,25,50,100,250,500,1000,2500,5000,10000 Q:SDMAX/SDFIG<99
     98 S SDFIG1=34+(SDMAX\SDFIG) S:SDFIG1<73 SDFIG1=73 Q
     99 ;
     100LINE(SDDT) ;Print statistics line
     101 ;Required input: SDDT=date
     102 D:$Y>(IOSL-3) HDR,HD1 Q:SDOUT  S SDCT=^TMP("SCRPW",$J,SDIV,"YR",SDDT),SDMO=$E(SDDT,4,5),SDYR=(17+$E(SDDT))_$E(SDDT,2,3),SDXMO=SDMO-1 S:SDXMO=0 SDXMO=12 S:$L(SDXMO)=1 SDXMO=0_SDXMO
     103 S SDXYR=$S(SDXMO=12:SDYR,1:SDYR+1)
     104 W !,SDMO,"/",SDYR," thru ",SDXMO,"/",SDXYR,?24,$J(SDCT,6,0),?32,"| " F SDI=1:1:(SDCT\SDFIG) W "*"
     105 Q

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPW62.m

    r613 r623  
    1 SCRPW62 ;BP-CIOFO/KEITH - SC veterans awaiting appointments ; 23 August 2002@20:23  ; Compiled August 20, 2007 14:21:08
    2         ;;5.3;Scheduling;**267,269,358,491**;AUG 13, 1993;Build 53
    3         ;
    4         ;Prompt for report parameters
    5         ;
    6         N SDOUT,DIR,DTOUT,DUOUT,SDFMT,SDATES,SDDIV,SDRPT,SDSCVT
    7         N SDELIM,SDX,ZTSAVE,X,Y
    8         S SDOUT=0
    9         D TITL^SCRPW50("SC Veterans Awaiting Appointments")
    10         W !,"Note: Once the scheduling replacement application has been implemented at your"
    11         W !,"site, this report will no longer be accurate."
    12 RPT     D SUBT^SCRPW50("**** Report Type Selection ****")
    13         S DIR(0)="S^E:ENTERED WITH NO APPOINTMENT PROVIDED;A:APPOINTMENTS BEYOND DATE DESIRED",DIR("A")="Select report type"
    14         S DIR("?",1)="Specify 'E' to return SC veterans entered but not yet provided an appointment,"
    15         S DIR("?")="'A' to return SC veterans with appointments beyond the date desired."
    16         W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 G EXIT
    17         K DIR S SDRPT=Y D ENT:SDRPT="E",APPT:SDRPT="A" G:SDOUT EXIT
    18         D SUBT^SCRPW50("**** Patient Eligibility Selection ****")
    19         S DIR(0)="S^1:50-100% SC Veterans;2:0-50% SC Veterans;3:All SC Veterans"
    20         S DIR("A")="Select eligibility type"
    21         S DIR("?")="Specify the eligibility of the patients you wish to include."
    22         W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 G EXIT
    23         K DIR S SDSCVT=Y
    24 FMT     D SUBT^SCRPW50("**** Report Format Selection ****")
    25         S DIR(0)="S^D:DETAILED REPORT;S:STATISTICS ONLY"
    26         S DIR("A")="Select report format"
    27         S DIR("?")="Specify the report format desired."
    28         W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 G EXIT
    29         K DIR S SDFMT=Y
    30         I SDFMT="S" S SDELIM=0 G QUE
    31         D SUBT^SCRPW50("**** Output Format Selection ****")
    32         S DIR(0)="Y",DIR("A")="Return report output in delimited format"
    33         S DIR("B")="NO"
    34         S DIR("?",1)="Specify if you would like the report output to be in delimited format for"
    35         S DIR("?",2)="transfer to a spreadsheet.  The delimited output will not include rated SC"
    36         S DIR("?")="disabilities for 0-50% SC veterans (as included in the text formatted report)."
    37         W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 G EXIT
    38         S SDELIM=Y
    39         ;
    40 QUE     ;Queue output
    41         ;W !!,"This report requires ",$S(SDELIM:"greater than ",1:""),"132 columns for output!"
    42         W !!,"This report requires the following steps to be converted to 'EXCEL':"
    43         W !,"1 - Copy it into WORD and replace '!^p' with null"
    44         W !,"2 - Save this file as *.txt format"
    45         W !,"3 - Open this file in 'EXCEL' with the All Files(*.*) type of file, listing it with one delimiter: '^'."
    46         F SDX="SDELIM","SDRPT","SDSCVT","SDATES","SDDIV","SDDIV(","SDFMT" S ZTSAVE(SDX)=""
    47         W ! D EN^XUTMDEVQ("START^SCRPW62","SC Veterans Awaiting Appointments",.ZTSAVE) D DISP0^SCRPW23
    48         Q
    49         ;
    50 ENT     ;Date entered parameters
    51         S SDATES=1 Q
    52         ;
    53         ;Following logic suppressed by request
    54         D SUBT^SCRPW50("**** Report Time Frame ****")
    55         S DIR(0)="S^1:THE PAST YEAR;2:THE PAST TWO YEARS;3:THE PAST 3 YEARS"
    56         S DIR("A")="Include SC veterans entered during"
    57         S DIR("?")="Specify the time frame in which these patients were entered in VistA."
    58         W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q
    59         S SDATES=Y
    60         Q
    61         ;
    62 APPT    ;Appointment delay parameters
    63         I '$$DIVA^SCRPW17(.SDDIV) S SDOUT=1 Q
    64         S SDATES=30 Q
    65         ;
    66         ;Following logic suppressed by request
    67         D SUBT^SCRPW50("**** Report Time Frame ****")
    68         S DIR(0)="S^30:>30 DAYS BEYOND 'DESIRED DATE';60:>60 DAYS BEYOND 'DESIRED DATE;90:>90 DAYS BEYOND 'DESIRED DATE';180:>180 DAYS BEYOND 'DESIRED DATE'"
    69         S DIR("A")="Include SC veterans with future appointments greater than"
    70         S DIR("?")="Specify the difference between 'desired date' and the appointement date."
    71         W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q
    72         S SDATES=Y
    73         Q
    74         ;
    75 START   ;Gather report data
    76         N SDSTOP,SDOUT,SDSTOP,SDPAGE,SDLINE,SDPNOW,SDT,SDX
    77         I '$D(ZTQUEUED),$E(IOST)="C" D WAIT^DICD
    78         K ^TMP("SCRPW",$J) S (SDSTOP,SDOUT)=0,SDPAGE=1,SDLINE=""
    79         S $P(SDLINE,"-",(IOM+1))=""
    80         S SDPNOW=$$FMTE^XLFDT($E($$NOW^XLFDT(),1,12))
    81         S SDX=$S(SDSCVT=1:"SC 50-100% ",SDSCVT=2:"SC < 50% ",1:"")
    82         S SDT(1)="<*>  SC VETERANS AWAITING APPOINTMENTS  <*>"
    83         S SDT(2)=$S(SDRPT="E":SDX_"PATIENTS ENTERED IN THE PAST "_$S(SDATES=1:"YEAR",1:SDATES_" YEARS")_" WITHOUT AN APPOINTMENT",1:SDX_"PATIENTS WAITING > "_SDATES_" DAYS BEYOND APPOINTMENT 'DESIRED DATE'")
    84         D @(SDRPT_"^SCRPW63") W !!
    85         D EXIT
    86         Q
    87         ;
    88 SCEL(SDE,SDSCVT)        ;Gather SC eligibility codes
    89         ;Input: SDE=array to return list of codes in the format SDE(n) where
    90         ;           'n' is the ifn in file #8 (pass by reference)
    91         ;       SDSCVT=type of SC vets to include
    92         N SDE81,SDX,SDI,SDII
    93         S SDI=0 F  S SDI=$O(^DIC(8.1,SDI)) Q:'SDI  D
    94         .S SDX=$G(^DIC(8.1,SDI,0))
    95         .Q:$P(SDX,U,5)'="Y"  S SDX=$P(SDX,U,4)
    96         .I SDSCVT=1,SDX'=1 Q  ;50-100% SC only
    97         .I SDSCVT=2,SDX'=3 Q  ;0-50% SC only
    98         .I SDSCVT=3,(SDX'=1&(SDX'=3)) Q  ;SC only
    99         .S SDII=0 F  S SDII=$O(^DIC(8,"D",SDI,SDII)) Q:'SDII  D
    100         ..S SDE(SDII)=SDX
    101         ..Q
    102         .Q
    103         Q
    104         ;
    105 EXIT    K ZTQUEUED,ZTSTOP,SDATES,SDDIV,SDFMT,SDRPT,SDELIM
    106         D END^SCRPW50 Q
    107         ;
    108 HDR     ;Print report header
    109         N X
    110         I SDELIM D HDRD Q
    111         I $E(IOST)="C",SDPAGE>1 N DIR S DIR(0)="E" D ^DIR S SDOUT=Y'=1 Q:SDOUT
    112         D STOP^SCRPW63 Q:SDOUT
    113         W:SDPAGE>1!($E(IOST)="C") $$XY^SCRPW50(IOF,1,0)
    114         W:$X $$XY^SCRPW50("",0,0) W SDLINE
    115         S X=0 F  S X=$O(SDT(X)) Q:'X  W !?(IOM-$L(SDT(X))\2),SDT(X)
    116         W !,SDLINE,!,"Date printed: ",SDPNOW,?((IOM-6)-$L(SDPAGE)),"Page: "
    117         W SDPAGE,!,SDLINE S SDPAGE=SDPAGE+1 Q
    118         ;
    119 HDRD    ;Header for delimited report
    120         Q:SDPAGE>1
    121         W !,SDLINE S X=0 F  S X=$O(SDT(X)) Q:'X  W !,SDT(X)
    122         W !,"Date printed: ",SDPNOW,!,SDLINE
    123         N ARR S ARR(1)="NAME^SSN^PRIM. ELIG.^DATE ENTERED^STREET ADDRESS^CITY^STATE^ZIP^PHONE NUMBER"
    124         S:SDRPT="A" ARR(1)=ARR(1)_"^APPOINTMENT DATE^CLINIC^CREDIT PAIR^DIVISION^DATE APPT. ENTERED^DESIRED DATE^DIFFERENCE (DESIRED DATE - APPT. DATE)^DIFFERENCE (DATE APPT. ENTERED - DESIRED DATE)"
    125         D DELIM(.ARR)
    126         S SDPAGE=SDPAGE+1 Q
    127         Q
    128         ;W !,"NAME^SSN^PRIM. ELIG.^DATE ENTERED^STREET ADDRESS^CITY^STATE^ZIP^PHONE NUMBER"
    129         ;W:SDRPT="A" "^APPOINTMENT DATE^CLINIC^CREDIT PAIR^DIVISION^DATE APPT. ENTERED^DESIRED DATE^DIFFERENCE (DESIRED DATE - APPT. DATE)^DIFFERENCE (DATE APPT. ENTERED - DESIRED DATE)"
    130         ;S SDPAGE=SDPAGE+1 Q
    131 DELIM(ARR)      ;enter delimiter in the end of wrapped line
    132         ;ARR - array of lines
    133         N DELIM,II,LN,LL,JJ
    134         S DELIM="!"
    135         F II=1:1 S LN=$G(ARR(II)),LL=$L(LN) Q:'LL  S LN=$P(LN," ")_DELIM_$P(LN," ",2,$L(LN," ")) F JJ=1:79:LL W !,$E(LN,JJ,JJ+78) W:JJ+79<LL DELIM I JJ+79=LL W $E(LN,LL) Q
     1SCRPW62 ;BP-CIOFO/KEITH - SC veterans awaiting appointments ; 23 August 2002@20:23
     2 ;;5.3;Scheduling;**267,269,358**;AUG 13, 1993
     3 ;
     4 ;Prompt for report parameters
     5 ;
     6 N SDOUT,DIR,DTOUT,DUOUT,SDFMT,SDATES,SDDIV,SDRPT,SDSCVT
     7 N SDELIM,SDX,ZTSAVE,X,Y
     8 S SDOUT=0
     9 D TITL^SCRPW50("SC Veterans Awaiting Appointments")
     10 W !,"Note: Once the scheduling replacement application has been implemented at your"
     11 W !,"site, this report will no longer be accurate."
     12RPT D SUBT^SCRPW50("**** Report Type Selection ****")
     13 S DIR(0)="S^E:ENTERED WITH NO APPOINTMENT PROVIDED;A:APPOINTMENTS BEYOND DATE DESIRED",DIR("A")="Select report type"
     14 S DIR("?",1)="Specify 'E' to return SC veterans entered but not yet provided an appointment,"
     15 S DIR("?")="'A' to return SC veterans with appointments beyond the date desired."
     16 W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 G EXIT
     17 K DIR S SDRPT=Y D ENT:SDRPT="E",APPT:SDRPT="A" G:SDOUT EXIT
     18 D SUBT^SCRPW50("**** Patient Eligibility Selection ****")
     19 S DIR(0)="S^1:50-100% SC Veterans;2:0-50% SC Veterans;3:All SC Veterans"
     20 S DIR("A")="Select eligibility type"
     21 S DIR("?")="Specify the eligibility of the patients you wish to include."
     22 W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 G EXIT
     23 K DIR S SDSCVT=Y
     24FMT D SUBT^SCRPW50("**** Report Format Selection ****")
     25 S DIR(0)="S^D:DETAILED REPORT;S:STATISTICS ONLY"
     26 S DIR("A")="Select report format"
     27 S DIR("?")="Specify the report format desired."
     28 W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 G EXIT
     29 K DIR S SDFMT=Y
     30 I SDFMT="S" S SDELIM=0 G QUE
     31 D SUBT^SCRPW50("**** Output Format Selection ****")
     32 S DIR(0)="Y",DIR("A")="Return report output in delimited format"
     33 S DIR("B")="NO"
     34 S DIR("?",1)="Specify if you would like the report output to be in delimited format for"
     35 S DIR("?",2)="transfer to a spreadsheet.  The delimited output will not include rated SC"
     36 S DIR("?")="disabilities for 0-50% SC veterans (as included in the text formatted report)."
     37 W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 G EXIT
     38 S SDELIM=Y
     39 ;
     40QUE ;Queue output
     41 W !!,"This report requires ",$S(SDELIM:"greater than ",1:""),"132 columns for output!"
     42 F SDX="SDELIM","SDRPT","SDSCVT","SDATES","SDDIV","SDDIV(","SDFMT" S ZTSAVE(SDX)=""
     43 W ! D EN^XUTMDEVQ("START^SCRPW62","SC Veterans Awaiting Appointments",.ZTSAVE) D DISP0^SCRPW23
     44 Q
     45 ;
     46ENT ;Date entered parameters
     47 S SDATES=1 Q
     48 ;
     49 ;Following logic suppressed by request
     50 D SUBT^SCRPW50("**** Report Time Frame ****")
     51 S DIR(0)="S^1:THE PAST YEAR;2:THE PAST TWO YEARS;3:THE PAST 3 YEARS"
     52 S DIR("A")="Include SC veterans entered during"
     53 S DIR("?")="Specify the time frame in which these patients were entered in VistA."
     54 W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q
     55 S SDATES=Y
     56 Q
     57 ;
     58APPT ;Appointment delay parameters
     59 I '$$DIVA^SCRPW17(.SDDIV) S SDOUT=1 Q
     60 S SDATES=30 Q
     61 ;
     62 ;Following logic suppressed by request
     63 D SUBT^SCRPW50("**** Report Time Frame ****")
     64 S DIR(0)="S^30:>30 DAYS BEYOND 'DESIRED DATE';60:>60 DAYS BEYOND 'DESIRED DATE;90:>90 DAYS BEYOND 'DESIRED DATE';180:>180 DAYS BEYOND 'DESIRED DATE'"
     65 S DIR("A")="Include SC veterans with future appointments greater than"
     66 S DIR("?")="Specify the difference between 'desired date' and the appointement date."
     67 W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q
     68 S SDATES=Y
     69 Q
     70 ;
     71START ;Gather report data
     72 N SDSTOP,SDOUT,SDSTOP,SDPAGE,SDLINE,SDPNOW,SDT,SDX
     73 I '$D(ZTQUEUED),$E(IOST)="C" D WAIT^DICD
     74 K ^TMP("SCRPW",$J) S (SDSTOP,SDOUT)=0,SDPAGE=1,SDLINE=""
     75 S $P(SDLINE,"-",(IOM+1))=""
     76 S SDPNOW=$$FMTE^XLFDT($E($$NOW^XLFDT(),1,12))
     77 S SDX=$S(SDSCVT=1:"SC 50-100% ",SDSCVT=2:"SC < 50% ",1:"")
     78 S SDT(1)="<*>  SC VETERANS AWAITING APPOINTMENTS  <*>"
     79 S SDT(2)=$S(SDRPT="E":SDX_"PATIENTS ENTERED IN THE PAST "_$S(SDATES=1:"YEAR",1:SDATES_" YEARS")_" WITHOUT AN APPOINTMENT",1:SDX_"PATIENTS WAITING > "_SDATES_" DAYS BEYOND APPOINTMENT 'DESIRED DATE'")
     80 D @(SDRPT_"^SCRPW63") W !!
     81 D EXIT
     82 Q
     83 ;
     84SCEL(SDE,SDSCVT) ;Gather SC eligibility codes
     85 ;Input: SDE=array to return list of codes in the format SDE(n) where
     86 ;           'n' is the ifn in file #8 (pass by reference)
     87 ;       SDSCVT=type of SC vets to include
     88 N SDE81,SDX,SDI,SDII
     89 S SDI=0 F  S SDI=$O(^DIC(8.1,SDI)) Q:'SDI  D
     90 .S SDX=$G(^DIC(8.1,SDI,0))
     91 .Q:$P(SDX,U,5)'="Y"  S SDX=$P(SDX,U,4)
     92 .I SDSCVT=1,SDX'=1 Q  ;50-100% SC only
     93 .I SDSCVT=2,SDX'=3 Q  ;0-50% SC only
     94 .I SDSCVT=3,(SDX'=1&(SDX'=3)) Q  ;SC only
     95 .S SDII=0 F  S SDII=$O(^DIC(8,"D",SDI,SDII)) Q:'SDII  D
     96 ..S SDE(SDII)=SDX
     97 ..Q
     98 .Q
     99 Q
     100 ;
     101EXIT K ZTQUEUED,ZTSTOP,SDATES,SDDIV,SDFMT,SDRPT,SDELIM
     102 D END^SCRPW50 Q
     103 ;
     104HDR ;Print report header
     105 N X
     106 I SDELIM D HDRD Q
     107 I $E(IOST)="C",SDPAGE>1 N DIR S DIR(0)="E" D ^DIR S SDOUT=Y'=1 Q:SDOUT
     108 D STOP^SCRPW63 Q:SDOUT
     109 W:SDPAGE>1!($E(IOST)="C") $$XY^SCRPW50(IOF,1,0)
     110 W:$X $$XY^SCRPW50("",0,0) W SDLINE
     111 S X=0 F  S X=$O(SDT(X)) Q:'X  W !?(IOM-$L(SDT(X))\2),SDT(X)
     112 W !,SDLINE,!,"Date printed: ",SDPNOW,?((IOM-6)-$L(SDPAGE)),"Page: "
     113 W SDPAGE,!,SDLINE S SDPAGE=SDPAGE+1 Q
     114 ;
     115HDRD ;Header for delimited report
     116 Q:SDPAGE>1
     117 W !,SDLINE S X=0 F  S X=$O(SDT(X)) Q:'X  W !,SDT(X)
     118 W !,"Date printed: ",SDPNOW,!,SDLINE
     119 W !,"NAME^SSN^PRIM. ELIG.^DATE ENTERED INTO FILE^STREET ADDRESS^CITY^STATE^ZIP^PHONE NUMBER"
     120 W:SDRPT="A" "^APPOINTMENT DATE^CLINIC^CREDIT PAIR^DIVISION^DATE APPT. ENTERED^DESIRED DATE^DIFFERENCE (DESIRED DATE - APPT. DATE)^DIFFERENCE (DATE APPT. ENTERED - DESIRED DATE)"
     121 S SDPAGE=SDPAGE+1 Q

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPW63.m

    r613 r623  
    1 SCRPW63 ;BP-CIOFO/KEITH - SC veterans awaiting appointments (cont.) ; 23 August 2002@20:23
    2         ;;5.3;Scheduling;**267,269,357,491**;AUG 13, 1993;Build 53
    3         ;
    4 E       ;Gather data for patients entered report
    5         N DFN,SDX,SDATE,SD0,SDSCEL,SDEL,SDYR,SDREL,SDTOT,SDSDT,SDLVDT,SDEDT
    6         N SDNAME
    7         D SCEL^SCRPW62(.SDSCEL,SDSCVT)  ;Get eligibility code pointers
    8         S (SDSDT,SDATE)=DT-(10000*SDATES),SDSTOP=0
    9         ;Find the patients entered after date specified
    10         S DFN=0 F  Q:SDSTOP  S DFN=$O(^DPT(DFN)) Q:'DFN  D
    11         .Q:$D(^DPT(DFN,-9))  ;Skip merged records
    12         .I DFN#1000=0 D STOP Q:SDSTOP  ;Check for stop task request
    13         .S SDLVDT=""
    14         .S SD0=$G(^DPT(DFN,0)) Q:'$L(SD0)
    15         .S SDEDT=$P(SD0,U,16) S:SDEDT SDLVDT=SDEDT
    16         .I SDEDT,SDEDT<SDATE Q  ;Date entered < start date
    17         .I 'SDEDT,SDLVDT<SDATE Q  ;No date entered, last valid date < start
    18         .S SDEL=+$G(^DPT(DFN,.36)) Q:'$D(SDSCEL(SDEL))  ;Only SC vets
    19         .Q:+$G(^DPT(DFN,.35))  ;No deceased patients
    20         .Q:$$SCHAPP(DFN)  ;Appointments not cancelled by clinic?
    21         .S SDYR=$$FMDIFF^XLFDT(DT,$S(SDEDT:SDEDT,1:SDLVDT))\365.25  ;Year entered
    22         .S SDEL=SDSCEL(SDEL) D  Q:SDFMT="S"
    23         ..;Record statistics
    24         ..S ^TMP("SCRPW",$J,"STATS",SDYR,SDEL)=$G(^TMP("SCRPW",$J,"STATS",SDYR,SDEL))+1
    25         ..Q
    26         .S SDNAME=$P(SD0,U) Q:'$L(SDNAME)
    27         .S ^TMP("SCRPW",$J,SDEL,SDNAME,DFN)=SD0
    28         .Q
    29         Q:SDSTOP
    30         D:$E(IOST,1,2)="C-" DISP0^SCRPW23
    31         I '$D(^TMP("SCRPW",$J)) D  Q  ;Negative report
    32         .D HDR^SCRPW62 S SDX="No patients found within report parameters!"
    33         .W !!?(132-$L(SDX)\2),SDX
    34         .I $E(IOST)="C",'SDOUT N DIR S DIR(0)="E" D ^DIR
    35         .Q
    36         ;Detailed report
    37         I SDFMT="D" D HDR^SCRPW62 S SDEL=0 F  S SDEL=$O(^TMP("SCRPW",$J,SDEL)) Q:'SDEL!SDOUT  D
    38         .S SDNAME="" F  S SDNAME=$O(^TMP("SCRPW",$J,SDEL,SDNAME)) Q:SDNAME=""!SDOUT  S DFN=0 D
    39         ..F  S DFN=$O(^TMP("SCRPW",$J,SDEL,SDNAME,DFN)) Q:'DFN!SDOUT  D
    40         ...S SDREL=$S(SDEL=1:0,1:+$P($G(^DPT(DFN,.372,0)),U,4))
    41         ...D:$Y>(IOSL-(4+SDREL)) HDR^SCRPW62 Q:SDOUT
    42         ...S SDX=^TMP("SCRPW",$J,SDEL,SDNAME,DFN) D PLINE(DFN,SDX,SDEL)
    43         ...Q
    44         .Q
    45         Q:SDOUT
    46 ESUM    ;Print summary
    47         G:SDELIM EQ
    48         S SDT(3)="STATISTICAL SUMMARY" D HDR^SCRPW62 Q:SDOUT
    49         W !! S SDYR="",SDTOT=0
    50         F  S SDYR=$O(^TMP("SCRPW",$J,"STATS",SDYR)) Q:SDYR=""  D
    51         .S SDEL=0 F  S SDEL=$O(^TMP("SCRPW",$J,"STATS",SDYR,SDEL)) Q:'SDEL  D
    52         ..S SDX=$$CSCEL(SDEL)_" veterans entered "_$S(SDYR=0:"in the past year",SDYR=1:"two years ago",SDYR=2:"three years ago",1:"")_":"
    53         ..W !?36,$J(SDX,45),?83,$J(^TMP("SCRPW",$J,"STATS",SDYR,SDEL),6,0)
    54         ..S SDTOT=SDTOT+^TMP("SCRPW",$J,"STATS",SDYR,SDEL)
    55         ..Q
    56         .Q
    57         W !?36,$E(SDLINE,1,53),!?75,"TOTAL:",?83,$J(SDTOT,6,0)
    58 EQ      I $E(IOST,1,2)="C-" N DIR S DIR(0)="E" W !! D ^DIR
    59         Q
    60         ;
    61 SCHAPP(DFN)     ;Look for scheduled appointments not cancelled by clinic
    62         ; Input: DFN=patient ifn
    63         ;Output: '1' if appointments exist, '0' otherwise
    64         N SDI,SDX,SDY
    65         S (SDI,SDY)=0
    66         F  S SDI=$O(^DPT(DFN,"S",SDI)) Q:'SDI!SDY  D
    67         .S SDX=$G(^DPT(DFN,"S",SDI,0)) Q:'$L(SDX)
    68         .S SDX=$P(SDX,U,2) I $L(SDX),"CA"[SDX Q
    69         .S SDY=1
    70         .Q
    71         Q SDY
    72         ;
    73 A       ;Gather data for future appointments report
    74         N DFN,SDA0,SDX,SDI,SDSCEL,SDEL,SDDATE,SDIFF,SDAPT,SDIVL,SDIVN
    75         N SDREL,SDTOT,SDIV,SD0,SDNAME
    76         D SCEL^SCRPW62(.SDSCEL,SDSCVT)  ;Get eligibility code pointers
    77         S DFN=0 F  S DFN=$O(^DPT(DFN)) Q:'DFN!SDSTOP  D
    78         .I DFN#1000=0 D STOP Q:SDSTOP  ;Check for stop task request
    79         .S SDEL=+$G(^DPT(DFN,.36)) Q:'$D(SDSCEL(SDEL))  ;Only SC vets
    80         .S SDEL=SDSCEL(SDEL)
    81         .Q:+$G(^DPT(DFN,.35))  ;No deceased patients
    82         .S SDI=DT F  S SDI=$O(^DPT(DFN,"S",SDI)) Q:'SDI  D
    83         ..S SDDATE=+$G(^DPT(DFN,"S",SDI,1)) Q:'SDDATE  Q:SDDATE>SDI
    84         ..S SDA0=$G(^DPT(DFN,"S",SDI,0)) Q:'$L(SDA0)
    85         ..S SDIV=$P($G(^SC(+SDA0,0)),U,15) Q:'$$DIV(.SDIV)  ;Division check
    86         ..;Exclude cancelled appointments
    87         ..S SDX=$P(SDA0,U,2) I $L(SDX),"PCA"[SDX Q
    88         ..S SDIFF=$$FMDIFF^XLFDT(SDI,SDDATE) Q:SDIFF'>SDATES
    89         ..S SDNAME=$P($G(^DPT(DFN,0)),U) Q:'$L(SDNAME)
    90         ..;Record detailed information
    91         ..S ^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN,SDI)=SDDATE_U_SDA0
    92         ..S ^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN)=$G(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN))+1
    93         ..Q
    94         .Q
    95         Q:SDSTOP
    96         ;Tally up statistics
    97         S SDIV=0 F  S SDIV=$O(^TMP("SCRPW",$J,SDIV)) Q:'SDIV  D
    98         .S SDEL=0 F  S SDEL=$O(^TMP("SCRPW",$J,SDIV,SDEL)) Q:'SDEL  D
    99         ..S SDNAME="" F  S SDNAME=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME)) Q:SDNAME=""!SDOUT  D
    100         ...S DFN=0 F  S DFN=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN)) Q:'DFN  D
    101         ....S ^TMP("SCRPW",$J,"STATS",SDIV,SDEL,"PTS")=$G(^TMP("SCRPW",$J,"STATS",SDIV,SDEL,"PTS"))+1
    102         ....S SDI=0 F  S SDI=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN,SDI)) Q:'SDI  D
    103         .....S ^TMP("SCRPW",$J,"STATS",SDIV,SDEL,"APPTS")=$G(^TMP("SCRPW",$J,"STATS",SDIV,SDEL,"APPTS"))+1
    104         .....Q
    105         ....Q
    106         ...Q
    107         ..Q
    108         .Q
    109         Q:SDSTOP
    110         ;Print report
    111         S SDIV="" F  S SDIV=$O(SDDIV(SDIV)) Q:'SDIV  S SDIV(SDDIV(SDIV))=SDIV
    112         I 'SDDIV,$P(SDDIV,U,2)'="ALL DIVISIONS" D
    113         .S SDIV($P(SDDIV,U,2))=$$PRIM^VASITE()
    114         .Q
    115         I $P(SDDIV,U,2)="ALL DIVISIONS" S SDI=0 D
    116         .F  S SDI=$O(^TMP("SCRPW",$J,SDI)) Q:'SDI  D
    117         ..S SDX=$P($G(^DG(40.8,SDI,0)),U) S:$L(SDX) SDIV(SDX)=SDI
    118         ..Q
    119         .Q
    120         D:$E(IOST)="C" DISP0^SCRPW23
    121         I '$D(^TMP("SCRPW",$J)) D  Q  ;Negative report
    122         .S SDIV=0 D DHDR^SCRPW40(3,.SDT),HDR^SCRPW62
    123         .S SDX="No appointments found that meet report criteria."
    124         .I SDELIM W !,SDX Q
    125         .W !!?(IOM-$L(SDX)\2),SDX
    126         .I $E(IOST)="C",'SDOUT N DIR S DIR(0)="E" D ^DIR
    127         .Q
    128         G:SDFMT="S" ASUM
    129         ;Print detailed report by division
    130         S SDIVN="" F  S SDIVN=$O(SDIV(SDIVN)) Q:SDIVN=""!SDOUT  D
    131         .S SDIV=SDIV(SDIVN) D ADPRT(.SDIV)
    132         .Q
    133         Q:SDOUT
    134         ;Print summary
    135 ASUM    G:SDELIM AQ
    136         S SDT(3)="STATISTICAL SUMMARY" D HDR^SCRPW62 Q:SDOUT
    137         W !! S (SDTOT,SDIV,SDIVL)=0,SDIVN=""
    138         F  S SDIVN=$O(SDIV(SDIVN)) Q:SDIVN=""  D
    139         .S SDIVN(SDIV(SDIVN))=SDIVN S:$L(SDIVN)>SDIVL SDIVL=$L(SDIVN)
    140         F  S SDIV=$O(^TMP("SCRPW",$J,"STATS",SDIV)) Q:'SDIV  D
    141         .S SDEL=0 F  S SDEL=$O(^TMP("SCRPW",$J,"STATS",SDIV,SDEL)) Q:'SDEL  D
    142         ..S SDAPT=^TMP("SCRPW",$J,"STATS",SDIV,SDEL,"APPTS"),SDTOT=SDTOT+SDAPT
    143         ..S SDX=$$CSCEL(SDEL)_" appointments at "_SDIVN(SDIV)_":"
    144         ..W !?(50-SDIVL),$J(SDX,(28+SDIVL)),?80,$J(SDAPT,6,0)
    145         ..Q
    146         .Q
    147         W !?(50-SDIVL),$E(SDLINE,1,(36+SDIVL)),!?72,"TOTAL:",?80,$J(SDTOT,6,0)
    148 AQ      I $E(IOST)="C",'SDOUT N DIR S DIR(0)="E" D ^DIR
    149         Q
    150         ;
    151 DIV(SDIV)       ;Check division
    152         S:'$L(SDIV) SDIV=$$PRIM^VASITE()
    153         Q:'SDDIV 1  Q $D(SDDIV(+SDIV))
    154         ;
    155         ;
    156 STOP    ;Check for stop task request
    157         S:$G(ZTQUEUED) (SDOUT,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q
    158         ;
    159 ADPRT(SDIV)     ;Print report for a division
    160         D DHDR^SCRPW40(3,.SDT) S:SDELIM SDPAGE=1
    161         I '$D(^TMP("SCRPW",$J,SDIV)) D HDR^SCRPW62 Q:SDOUT  D  Q
    162         .S SDX="No appointments found for this division within report parameters!"
    163         .I SDELIM W !,SDX Q
    164         .W !!?(132-$L(SDX)\2),SDX Q
    165         D HDR^SCRPW62 Q:SDOUT
    166         S SDEL="" F  S SDEL=$O(^TMP("SCRPW",$J,SDIV,SDEL)) Q:'SDEL!SDOUT  D
    167         .S SDNAME="" F  S SDNAME=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME)) Q:SDNAME=""!SDOUT  D
    168         ..S DFN=0 F  S DFN=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN)) Q:'DFN!SDOUT  D
    169         ...S SD0=$G(^DPT(DFN,0)) Q:'$L(SD0)
    170         ...S SDREL=$S(SDEL=1:0,1:+$P($G(^DPT(DFN,.372,0)),U,4))
    171         ...S SDREL=SDREL+^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN)
    172         ...D:$Y>(IOSL-(4+SDREL)) HDR^SCRPW62 Q:SDOUT
    173         ...D PLINE(DFN,SD0,SDEL)
    174         ...Q
    175         ..Q
    176         .Q
    177         Q
    178         ;
    179 PLINE(DFN,SD0,SDEL)     ;Print patient detail line         
    180         ;Input: DFN=patient ifn
    181         ;       SD0=zeroeth node of patient record
    182         ;      SDEL=1 or 3 to denote SC > or < 50%
    183         ;
    184         N SDSSN,SDNAME,SDDTE,SDADD,SDST,SDX,SDI,SDY,SDELN,SDZIP,SDZ,SDZA,SDII
    185         S SDNAME=$P(SD0,U),SDSSN=$P(SD0,U,9),SDDTE=$$FMTE^XLFDT($P(SD0,U,16))
    186         S SDSSN=$E(SDSSN,1,3)_"-"_$E(SDSSN,4,5)_"-"_$E(SDSSN,6,10)
    187         S SDEL=$G(SDEL),SDELN=$$CSCEL(SDEL),SDADD=$G(^DPT(DFN,.11))
    188         S SDST=$P($G(^DIC(5,+$P(SDADD,U,5),0)),U,2),SDZIP=$P(SDADD,U,12)
    189         S:$L(SDZIP)=9 SDZIP=$E(SDZIP,1,5)_"-"_$E(SDZIP,6,9)
    190         I SDELIM D  ;Set up delimited output
    191         .S SDZ=SDNAME_U_SDSSN_U_SDELN_U_SDDTE_U_$P(SDADD,U)_U_$P(SDADD,U,4)
    192         .S SDZ=SDZ_U_SDST_U_SDZIP_U_$P($G(^DPT(DFN,.13)),U)
    193         .Q
    194         I 'SDELIM D
    195         .;Print name, SSN, eligibility, date entered, address and phone number
    196         .W !,"Name: ",SDNAME,?39,"SSN: ",SDSSN,?58,"Prim. Elig.: ",SDELN
    197         .W ?84,"Date entered: ",SDDTE,!?10,"Address: ",$P(SDADD,U)
    198         .W ?55,$P(SDADD,U,4),$S($L($P(SDADD,U,4)):", ",1:""),SDST,"  ",SDZIP
    199         .W ?88,"Phone number: ",$P($G(^DPT(DFN,.13)),U)
    200         .;Print SC disabilities for 0-50% SC veterans
    201         .I SDEL=3 S SDI=0 F  S SDI=$O(^DPT(DFN,.372,SDI)) Q:'SDI  D
    202         ..S SDX=$G(^DPT(DFN,.372,SDI,0)) Q:'$P(SDX,U,3)
    203         ..S SDY=$G(^DIC(31,+SDX,0)) Q:'$L(SDY)
    204         ..W !?20,"SC disability: ",$P(SDY,U,3),"  ",$P(SDY,U)
    205         ..W ?89,"%SC: ",$P(SDX,U,2)
    206         ..Q
    207         .Q
    208         I SDRPT="E" D  Q
    209         .I SDELIM S SDZ(1)=SDZ D DELIM^SCRPW62(.SDZ) Q  ;W !,SDZ Q
    210         .W !
    211         .Q
    212         ;Print appointment details for future appointment report
    213         S SDI=0 D
    214         .F  S SDI=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN,SDI)) Q:'SDI  D
    215         ..S SDA0=^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN,SDI)
    216         ..I 'SDELIM D
    217         ...W !?30,"Appointment: ",$$FMTE^XLFDT(SDI)
    218         ...W ?63,$P($G(^SC(+$P(SDA0,U,2),0)),U),?96,"Desired date: "
    219         ...W $$FMTE^XLFDT(+SDA0),?124,"(",$$FMDIFF^XLFDT(SDI,+SDA0),")"
    220         ...Q
    221         ..I SDELIM D  ;Delimited output
    222         ...N SDC0,SDCP,SDCZ,SDADM,SDADME
    223         ...S SDC0=$G(^SC(+$P(SDA0,U,2),0)),SDCZ=$$CPAIR^SCRPW71(SDC0,.SDCP)
    224         ...S SDII=0,(SDZA,SDADM,SDADME)=""
    225         ...F  S SDII=$O(^SC(+$P(SDA0,U,2),"S",SDI,1,SDII)) D  Q:'SDII
    226         ....Q:+$G(^SC(+$P(SDA0,U,2),"S",SDI,1,+SDII,0))'=DFN
    227         ....S SDADM=$P(^SC(+$P(SDA0,U,2),"S",SDI,1,+SDII,0),U,7)
    228         ....S SDADME=$$FMTE^XLFDT(SDADM),SDII=0
    229         ....Q
    230         ...S SDCZ=SDCP_U_$P($$SITE^VASITE(,$P(SDC0,U,15)),U,2)_U_SDADME
    231         ...S SDZA=SDZA_U_$$FMTE^XLFDT(SDI)_U_$P(SDC0,U)_U_SDCZ
    232         ...S SDZA=SDZA_U_$$FMTE^XLFDT(+SDA0)_U_$$FMDIFF^XLFDT(SDI,+SDA0)
    233         ...S SDZA=SDZA_U_$S(SDADM:$$FMDIFF^XLFDT(+SDA0,SDADM),1:"")
    234         ...S SDZ(1)=SDZ_SDZA
    235         ...D DELIM^SCRPW62(.SDZ)  ;W !,SDZ,SDZA
    236         ...Q
    237         ..Q
    238         .Q
    239         W:'SDELIM ! Q
    240         ;
    241 CSCEL(SDEL)     ;Convert SC elig. to external
    242         Q $S(SDEL=1:"SC 50-100%",SDEL=3:"SC < 50%",1:"")
     1SCRPW63 ;BP-CIOFO/KEITH - SC veterans awaiting appointments (cont.) ; 23 August 2002@20:23
     2 ;;5.3;Scheduling;**267,269,357**;AUG 13, 1993
     3 ;
     4E ;Gather data for patients entered report
     5 N DFN,SDX,SDATE,SD0,SDSCEL,SDEL,SDYR,SDREL,SDTOT,SDSDT,SDLVDT,SDEDT
     6 N SDNAME
     7 D SCEL^SCRPW62(.SDSCEL,SDSCVT)  ;Get eligibility code pointers
     8 S (SDSDT,SDATE)=DT-(10000*SDATES),SDSTOP=0
     9 ;Find the patients entered after date specified
     10 S DFN=0 F  Q:SDSTOP  S DFN=$O(^DPT(DFN)) Q:'DFN  D
     11 .Q:$D(^DPT(DFN,-9))  ;Skip merged records
     12 .I DFN#1000=0 D STOP Q:SDSTOP  ;Check for stop task request
     13 .S SDLVDT=""
     14 .S SD0=$G(^DPT(DFN,0)) Q:'$L(SD0)
     15 .S SDEDT=$P(SD0,U,16) S:SDEDT SDLVDT=SDEDT
     16 .I SDEDT,SDEDT<SDATE Q  ;Date entered < start date
     17 .I 'SDEDT,SDLVDT<SDATE Q  ;No date entered, last valid date < start
     18 .S SDEL=+$G(^DPT(DFN,.36)) Q:'$D(SDSCEL(SDEL))  ;Only SC vets
     19 .Q:+$G(^DPT(DFN,.35))  ;No deceased patients
     20 .Q:$$SCHAPP(DFN)  ;Appointments not cancelled by clinic?
     21 .S SDYR=$$FMDIFF^XLFDT(DT,$S(SDEDT:SDEDT,1:SDLVDT))\365.25  ;Year entered
     22 .S SDEL=SDSCEL(SDEL) D  Q:SDFMT="S"
     23 ..;Record statistics
     24 ..S ^TMP("SCRPW",$J,"STATS",SDYR,SDEL)=$G(^TMP("SCRPW",$J,"STATS",SDYR,SDEL))+1
     25 ..Q
     26 .S SDNAME=$P(SD0,U) Q:'$L(SDNAME)
     27 .S ^TMP("SCRPW",$J,SDEL,SDNAME,DFN)=SD0
     28 .Q
     29 Q:SDSTOP
     30 D:$E(IOST,1,2)="C-" DISP0^SCRPW23
     31 I '$D(^TMP("SCRPW",$J)) D  Q  ;Negative report
     32 .D HDR^SCRPW62 S SDX="No patients found within report parameters!"
     33 .W !!?(132-$L(SDX)\2),SDX
     34 .I $E(IOST)="C",'SDOUT N DIR S DIR(0)="E" D ^DIR
     35 .Q
     36 ;Detailed report
     37 I SDFMT="D" D HDR^SCRPW62 S SDEL=0 F  S SDEL=$O(^TMP("SCRPW",$J,SDEL)) Q:'SDEL!SDOUT  D
     38 .S SDNAME="" F  S SDNAME=$O(^TMP("SCRPW",$J,SDEL,SDNAME)) Q:SDNAME=""!SDOUT  S DFN=0 D
     39 ..F  S DFN=$O(^TMP("SCRPW",$J,SDEL,SDNAME,DFN)) Q:'DFN!SDOUT  D
     40 ...S SDREL=$S(SDEL=1:0,1:+$P($G(^DPT(DFN,.372,0)),U,4))
     41 ...D:$Y>(IOSL-(4+SDREL)) HDR^SCRPW62 Q:SDOUT
     42 ...S SDX=^TMP("SCRPW",$J,SDEL,SDNAME,DFN) D PLINE(DFN,SDX,SDEL)
     43 ...Q
     44 .Q
     45 Q:SDOUT
     46ESUM ;Print summary
     47 G:SDELIM EQ
     48 S SDT(3)="STATISTICAL SUMMARY" D HDR^SCRPW62 Q:SDOUT
     49 W !! S SDYR="",SDTOT=0
     50 F  S SDYR=$O(^TMP("SCRPW",$J,"STATS",SDYR)) Q:SDYR=""  D
     51 .S SDEL=0 F  S SDEL=$O(^TMP("SCRPW",$J,"STATS",SDYR,SDEL)) Q:'SDEL  D
     52 ..S SDX=$$CSCEL(SDEL)_" veterans entered "_$S(SDYR=0:"in the past year",SDYR=1:"two years ago",SDYR=2:"three years ago",1:"")_":"
     53 ..W !?36,$J(SDX,45),?83,$J(^TMP("SCRPW",$J,"STATS",SDYR,SDEL),6,0)
     54 ..S SDTOT=SDTOT+^TMP("SCRPW",$J,"STATS",SDYR,SDEL)
     55 ..Q
     56 .Q
     57 W !?36,$E(SDLINE,1,53),!?75,"TOTAL:",?83,$J(SDTOT,6,0)
     58EQ I $E(IOST,1,2)="C-" N DIR S DIR(0)="E" W !! D ^DIR
     59 Q
     60 ;
     61SCHAPP(DFN) ;Look for scheduled appointments not cancelled by clinic
     62 ; Input: DFN=patient ifn
     63 ;Output: '1' if appointments exist, '0' otherwise
     64 N SDI,SDX,SDY
     65 S (SDI,SDY)=0
     66 F  S SDI=$O(^DPT(DFN,"S",SDI)) Q:'SDI!SDY  D
     67 .S SDX=$G(^DPT(DFN,"S",SDI,0)) Q:'$L(SDX)
     68 .S SDX=$P(SDX,U,2) I $L(SDX),"CA"[SDX Q
     69 .S SDY=1
     70 .Q
     71 Q SDY
     72 ;
     73A ;Gather data for future appointments report
     74 N DFN,SDA0,SDX,SDI,SDSCEL,SDEL,SDDATE,SDIFF,SDAPT,SDIVL,SDIVN
     75 N SDREL,SDTOT,SDIV,SD0,SDNAME
     76 D SCEL^SCRPW62(.SDSCEL,SDSCVT)  ;Get eligibility code pointers
     77 S DFN=0 F  S DFN=$O(^DPT(DFN)) Q:'DFN!SDSTOP  D
     78 .I DFN#1000=0 D STOP Q:SDSTOP  ;Check for stop task request
     79 .S SDEL=+$G(^DPT(DFN,.36)) Q:'$D(SDSCEL(SDEL))  ;Only SC vets
     80 .S SDEL=SDSCEL(SDEL)
     81 .Q:+$G(^DPT(DFN,.35))  ;No deceased patients
     82 .S SDI=DT F  S SDI=$O(^DPT(DFN,"S",SDI)) Q:'SDI  D
     83 ..S SDDATE=+$G(^DPT(DFN,"S",SDI,1)) Q:'SDDATE  Q:SDDATE>SDI
     84 ..S SDA0=$G(^DPT(DFN,"S",SDI,0)) Q:'$L(SDA0)
     85 ..S SDIV=$P($G(^SC(+SDA0,0)),U,15) Q:'$$DIV(.SDIV)  ;Division check
     86 ..;Exclude cancelled appointments
     87 ..S SDX=$P(SDA0,U,2) I $L(SDX),"PCA"[SDX Q
     88 ..S SDIFF=$$FMDIFF^XLFDT(SDI,SDDATE) Q:SDIFF'>SDATES
     89 ..S SDNAME=$P($G(^DPT(DFN,0)),U) Q:'$L(SDNAME)
     90 ..;Record detailed information
     91 ..S ^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN,SDI)=SDDATE_U_SDA0
     92 ..S ^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN)=$G(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN))+1
     93 ..Q
     94 .Q
     95 Q:SDSTOP
     96 ;Tally up statistics
     97 S SDIV=0 F  S SDIV=$O(^TMP("SCRPW",$J,SDIV)) Q:'SDIV  D
     98 .S SDEL=0 F  S SDEL=$O(^TMP("SCRPW",$J,SDIV,SDEL)) Q:'SDEL  D
     99 ..S SDNAME="" F  S SDNAME=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME)) Q:SDNAME=""!SDOUT  D
     100 ...S DFN=0 F  S DFN=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN)) Q:'DFN  D
     101 ....S ^TMP("SCRPW",$J,"STATS",SDIV,SDEL,"PTS")=$G(^TMP("SCRPW",$J,"STATS",SDIV,SDEL,"PTS"))+1
     102 ....S SDI=0 F  S SDI=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN,SDI)) Q:'SDI  D
     103 .....S ^TMP("SCRPW",$J,"STATS",SDIV,SDEL,"APPTS")=$G(^TMP("SCRPW",$J,"STATS",SDIV,SDEL,"APPTS"))+1
     104 .....Q
     105 ....Q
     106 ...Q
     107 ..Q
     108 .Q
     109 Q:SDSTOP
     110 ;Print report
     111 S SDIV="" F  S SDIV=$O(SDDIV(SDIV)) Q:'SDIV  S SDIV(SDDIV(SDIV))=SDIV
     112 I 'SDDIV,$P(SDDIV,U,2)'="ALL DIVISIONS" D
     113 .S SDIV($P(SDDIV,U,2))=$$PRIM^VASITE()
     114 .Q
     115 I $P(SDDIV,U,2)="ALL DIVISIONS" S SDI=0 D
     116 .F  S SDI=$O(^TMP("SCRPW",$J,SDI)) Q:'SDI  D
     117 ..S SDX=$P($G(^DG(40.8,SDI,0)),U) S:$L(SDX) SDIV(SDX)=SDI
     118 ..Q
     119 .Q
     120 D:$E(IOST)="C" DISP0^SCRPW23
     121 I '$D(^TMP("SCRPW",$J)) D  Q  ;Negative report
     122 .S SDIV=0 D DHDR^SCRPW40(3,.SDT),HDR^SCRPW62
     123 .S SDX="No appointments found that meet report criteria."
     124 .I SDELIM W !,SDX Q
     125 .W !!?(IOM-$L(SDX)\2),SDX
     126 .I $E(IOST)="C",'SDOUT N DIR S DIR(0)="E" D ^DIR
     127 .Q
     128 G:SDFMT="S" ASUM
     129 ;Print detailed report by division
     130 S SDIVN="" F  S SDIVN=$O(SDIV(SDIVN)) Q:SDIVN=""!SDOUT  D
     131 .S SDIV=SDIV(SDIVN) D ADPRT(.SDIV)
     132 .Q
     133 Q:SDOUT
     134 ;Print summary
     135ASUM G:SDELIM AQ
     136 S SDT(3)="STATISTICAL SUMMARY" D HDR^SCRPW62 Q:SDOUT
     137 W !! S (SDTOT,SDIV,SDIVL)=0,SDIVN=""
     138 F  S SDIVN=$O(SDIV(SDIVN)) Q:SDIVN=""  D
     139 .S SDIVN(SDIV(SDIVN))=SDIVN S:$L(SDIVN)>SDIVL SDIVL=$L(SDIVN)
     140 F  S SDIV=$O(^TMP("SCRPW",$J,"STATS",SDIV)) Q:'SDIV  D
     141 .S SDEL=0 F  S SDEL=$O(^TMP("SCRPW",$J,"STATS",SDIV,SDEL)) Q:'SDEL  D
     142 ..S SDAPT=^TMP("SCRPW",$J,"STATS",SDIV,SDEL,"APPTS"),SDTOT=SDTOT+SDAPT
     143 ..S SDX=$$CSCEL(SDEL)_" appointments at "_SDIVN(SDIV)_":"
     144 ..W !?(50-SDIVL),$J(SDX,(28+SDIVL)),?80,$J(SDAPT,6,0)
     145 ..Q
     146 .Q
     147 W !?(50-SDIVL),$E(SDLINE,1,(36+SDIVL)),!?72,"TOTAL:",?80,$J(SDTOT,6,0)
     148AQ I $E(IOST)="C",'SDOUT N DIR S DIR(0)="E" D ^DIR
     149 Q
     150 ;
     151DIV(SDIV) ;Check division
     152 S:'$L(SDIV) SDIV=$$PRIM^VASITE()
     153 Q:'SDDIV 1  Q $D(SDDIV(+SDIV))
     154 ;
     155 ;
     156STOP ;Check for stop task request
     157 S:$G(ZTQUEUED) (SDOUT,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q
     158 ;
     159ADPRT(SDIV) ;Print report for a division
     160 D DHDR^SCRPW40(3,.SDT) S:SDELIM SDPAGE=1
     161 I '$D(^TMP("SCRPW",$J,SDIV)) D HDR^SCRPW62 Q:SDOUT  D  Q
     162 .S SDX="No appointments found for this division within report parameters!"
     163 .I SDELIM W !,SDX Q
     164 .W !!?(132-$L(SDX)\2),SDX Q
     165 D HDR^SCRPW62 Q:SDOUT
     166 S SDEL="" F  S SDEL=$O(^TMP("SCRPW",$J,SDIV,SDEL)) Q:'SDEL!SDOUT  D
     167 .S SDNAME="" F  S SDNAME=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME)) Q:SDNAME=""!SDOUT  D
     168 ..S DFN=0 F  S DFN=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN)) Q:'DFN!SDOUT  D
     169 ...S SD0=$G(^DPT(DFN,0)) Q:'$L(SD0)
     170 ...S SDREL=$S(SDEL=1:0,1:+$P($G(^DPT(DFN,.372,0)),U,4))
     171 ...S SDREL=SDREL+^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN)
     172 ...D:$Y>(IOSL-(4+SDREL)) HDR^SCRPW62 Q:SDOUT
     173 ...D PLINE(DFN,SD0,SDEL)
     174 ...Q
     175 ..Q
     176 .Q
     177 Q
     178 ;
     179PLINE(DFN,SD0,SDEL) ;Print patient detail line         
     180 ;Input: DFN=patient ifn
     181 ;       SD0=zeroeth node of patient record
     182 ;      SDEL=1 or 3 to denote SC > or < 50%
     183 ;
     184 N SDSSN,SDNAME,SDDTE,SDADD,SDST,SDX,SDI,SDY,SDELN,SDZIP,SDZ,SDZA,SDII
     185 S SDNAME=$P(SD0,U),SDSSN=$P(SD0,U,9),SDDTE=$$FMTE^XLFDT($P(SD0,U,16))
     186 S SDSSN=$E(SDSSN,1,3)_"-"_$E(SDSSN,4,5)_"-"_$E(SDSSN,6,10)
     187 S SDEL=$G(SDEL),SDELN=$$CSCEL(SDEL),SDADD=$G(^DPT(DFN,.11))
     188 S SDST=$P($G(^DIC(5,+$P(SDADD,U,5),0)),U,2),SDZIP=$P(SDADD,U,12)
     189 S:$L(SDZIP)=9 SDZIP=$E(SDZIP,1,5)_"-"_$E(SDZIP,6,9)
     190 I SDELIM D  ;Set up delimited output
     191 .S SDZ=SDNAME_U_SDSSN_U_SDELN_U_SDDTE_U_$P(SDADD,U)_U_$P(SDADD,U,4)
     192 .S SDZ=SDZ_U_SDST_U_SDZIP_U_$P($G(^DPT(DFN,.13)),U)
     193 .Q
     194 I 'SDELIM D
     195 .;Print name, SSN, eligibility, date entered, address and phone number
     196 .W !,"Name: ",SDNAME,?39,"SSN: ",SDSSN,?58,"Prim. Elig.: ",SDELN
     197 .W ?84,"Date entered: ",SDDTE,!?10,"Address: ",$P(SDADD,U)
     198 .W ?55,$P(SDADD,U,4),$S($L($P(SDADD,U,4)):", ",1:""),SDST,"  ",SDZIP
     199 .W ?88,"Phone number: ",$P($G(^DPT(DFN,.13)),U)
     200 .;Print SC disabilities for 0-50% SC veterans
     201 .I SDEL=3 S SDI=0 F  S SDI=$O(^DPT(DFN,.372,SDI)) Q:'SDI  D
     202 ..S SDX=$G(^DPT(DFN,.372,SDI,0)) Q:'$P(SDX,U,3)
     203 ..S SDY=$G(^DIC(31,+SDX,0)) Q:'$L(SDY)
     204 ..W !?20,"SC disability: ",$P(SDY,U,3),"  ",$P(SDY,U)
     205 ..W ?89,"%SC: ",$P(SDX,U,2)
     206 ..Q
     207 .Q
     208 I SDRPT="E" D  Q
     209 .I SDELIM W !,SDZ Q
     210 .W !
     211 .Q
     212 ;Print appointment details for future appointment report
     213 S SDI=0 D
     214 .F  S SDI=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN,SDI)) Q:'SDI  D
     215 ..S SDA0=^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN,SDI)
     216 ..I 'SDELIM D
     217 ...W !?30,"Appointment: ",$$FMTE^XLFDT(SDI)
     218 ...W ?63,$P($G(^SC(+$P(SDA0,U,2),0)),U),?96,"Desired date: "
     219 ...W $$FMTE^XLFDT(+SDA0),?124,"(",$$FMDIFF^XLFDT(SDI,+SDA0),")"
     220 ...Q
     221 ..I SDELIM D  ;Delimited output
     222 ...N SDC0,SDCP,SDCZ,SDADM,SDADME
     223 ...S SDC0=$G(^SC(+$P(SDA0,U,2),0)),SDCZ=$$CPAIR^SCRPW71(SDC0,.SDCP)
     224 ...S SDII=0,(SDZA,SDADM,SDADME)=""
     225 ...F  S SDII=$O(^SC(+$P(SDA0,U,2),"S",SDI,1,SDII)) D  Q:'SDII
     226 ....Q:+$G(^SC(+$P(SDA0,U,2),"S",SDI,1,+SDII,0))'=DFN
     227 ....S SDADM=$P(^SC(+$P(SDA0,U,2),"S",SDI,1,+SDII,0),U,7)
     228 ....S SDADME=$$FMTE^XLFDT(SDADM),SDII=0
     229 ....Q
     230 ...S SDCZ=SDCP_U_$P($$SITE^VASITE(,$P(SDC0,U,15)),U,2)_U_SDADME
     231 ...S SDZA=SDZA_U_$$FMTE^XLFDT(SDI)_U_$P(SDC0,U)_U_SDCZ
     232 ...S SDZA=SDZA_U_$$FMTE^XLFDT(+SDA0)_U_$$FMDIFF^XLFDT(SDI,+SDA0)
     233 ...S SDZA=SDZA_U_$S(SDADM:$$FMDIFF^XLFDT(+SDA0,SDADM),1:"")
     234 ...W !,SDZ,SDZA
     235 ...Q
     236 ..Q
     237 .Q
     238 W:'SDELIM ! Q
     239 ;
     240CSCEL(SDEL) ;Convert SC elig. to external
     241 Q $S(SDEL=1:"SC 50-100%",SDEL=3:"SC < 50%",1:"")

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPW8.m

    r613 r623  
    1 SCRPW8  ;RENO/KEITH - Outpatient Encounter Workload Statistics ; 04 Feb 99  4:53 PM
    2         ;;5.3;Scheduling;**139,145,144,176,339,466,510**;AUG 13, 1993;Build 3
    3 QS      ;Queue outpatient encounter workload report
    4         D PARM^SCRPW9 Q
    5         ;
    6 PST     ;Print stats
    7         N X,Y,%
    8         D NOW^%DTC S Y=% X ^DD("DD") S SDPAGE=1,SDPNOW=$P(Y,":",1,2),SDDT=SDDTF,SDMC=$O(^DG(43,0)),SDMC=$G(^DG(43,+SDMC,"GL")),SDMD=$P(SDMC,U,2),(SDOUT,SDSTOP,SDFF)=0
    9         S SDDNAM=$P($G(^DG(40.8,+$$PRIM^VASITE(),0)),U,7),SDDNAM=$$GET1^DIQ(4,+SDDNAM,.01) S:'$L(SDDNAM) SDDNAM=$P($G(^DG(40.8,+$P(SDMC,U,3),0)),U)
    10         F I="SCRPW","SCRPWD","SCRPWC" K ^TMP(I,$J)
    11         F  S SDDT=$O(^SCE("B",SDDT)) Q:'SDDT!(SDDT>SDDTL)!SDOUT  S SDOE=0 D
    12         .F  S SDOE=$O(^SCE("B",SDDT,SDOE)) Q:'SDOE!SDOUT  S SDOE0=$$GETOE^SDOE(SDOE) I $L(SDOE0),'$P(SDOE0,U,6),$P(SDOE0,U,2),$P(SDOE0,U,11),$P(SDOE0,U,12) S SDDIV=$$DIV(),SDCG=$$CLGR() D COUNT
    13         .Q
    14         I '$D(^TMP("SCRPW",$J)) D XHDR S SDX="No activity found within the parameters specified." W !!?(80-$L(SDX)\2),SDX G EXIT
    15         F SDS1="SCRPW","SCRPWD","SCRPWC" S SDS2="" F  S SDS2=$O(^TMP(SDS1,$J,SDS2)) Q:SDS2=""!SDOUT  D STCT
    16         G:SDOUT EXIT D:$E(IOST)="C" DISP0^SCRPW23
    17         F SDS1="SCRPW","SCRPWD","SCRPWC" S SDS2="" F  S SDS2=$O(^TMP(SDS1,$J,SDS2)) Q:SDS2=""!SDOUT  D PRPT
    18         G:SDOUT EXIT
    19         D:SDZ(0) DPRT^SCRPW9("SCRPW",SDDNAM) G:SDOUT EXIT D:SDUL UNARL^SCRPW9("SCRPW",SDDNAM) G EXIT
    20         ;
    21 STCT    S (SDUNCO,SDCT,DFN)=0 D STOP Q:SDOUT
    22         F  S DFN=$O(^TMP(SDS1,$J,SDS2,"VISIT","ACC",DFN)) Q:'DFN  S SDUNCO=SDUNCO+1,SDDT=0 F  S SDDT=$O(^TMP(SDS1,$J,SDS2,"VISIT","ACC",DFN,SDDT)) Q:'SDDT  S SDCT=SDCT+1
    23         S ^TMP(SDS1,$J,SDS2,"UNIQUE","UNCO")=SDUNCO,^TMP(SDS1,$J,SDS2,"VISIT","OWK")=SDCT,(SDUNAR,SDCT,DFN)=0
    24         S DFN=0 F  S DFN=$O(^TMP(SDS1,$J,SDS2,"VISIT","OWK",DFN)) Q:'DFN  D NCT1
    25         S DFN=0 F  S DFN=$O(^TMP(SDS1,$J,SDS2,"VISIT","NWK",DFN)) Q:'DFN  D CT1
    26         S ^TMP(SDS1,$J,SDS2,"UNIQUE","UNAR")=SDUNAR,^TMP(SDS1,$J,SDS2,"VISIT","NWK")=SDCT Q
    27         ;
    28 PRPT    ;Print statistics page
    29         D STOP Q:SDOUT
    30         S SDCT=0 F SDI=1,2,3,11,14,"8-CC" S SDCT=SDCT+$G(^TMP(SDS1,$J,SDS2,SDI))
    31         D XHDR Q:SDOUT  D SHDR("O U T P A T I E N T   E N C O U N T E R   W O R K L O A D") Q:SDOUT  F SDI=11,14,3,1 D LIST(SDI) Q:SDOUT
    32         I $D(^TMP(SDS1,$J,SDS2,2)) D:$Y>(IOSL-4) XHDR Q:SDOUT  W !?10,"CHECKED OUT" S SDI=0 F  S SDI=$O(^TMP(SDS1,$J,SDS2,2,SDI)) Q:'SDI!SDOUT  S SDSTAT=$O(^TMP(SDS1,$J,SDS2,2,SDI,"")) D COT
    33         I $D(^TMP(SDS1,$J,SDS2,"8-CC")) D:$Y>(IOSL-4) XHDR Q:SDOUT  W !?10,"INPATIENT APPOINTMENT" S SDI=0 F  S SDI=$O(^TMP(SDS1,$J,SDS2,"8-CC",SDI)) Q:'SDI!SDOUT  S SDSTAT=$O(^TMP(SDS1,$J,SDS2,"8-CC",SDI,"")) D IAP
    34         D TOT S (SDI,SDCT)=0 F SDI=4,5,6,7,"8-NC",9,12,13 S SDCT=SDCT+$G(^TMP(SDS1,$J,SDS2,SDI))
    35         W !! D SHDR("N O N - W O R K L O A D") Q:SDOUT  F SDI="8-NC",12,4,6,5,7,9,10,13 D LIST(SDI) Q:SDOUT
    36         D TOT W !! D SHDR(($$HD2()_"   O U T P A T I E N T   V I S I T S")) Q:SDOUT  S SDCT=^TMP(SDS1,$J,SDS2,"VISIT","NWK")+^TMP(SDS1,$J,SDS2,"VISIT","OWK")
    37         D:$Y>(IOSL-4) XHDR Q:SDOUT  W !?10,"Act. Req./not accepted visits",?47,$J(^TMP(SDS1,$J,SDS2,"VISIT","NWK"),12),?62,$J($S(SDCT=0:0,1:(^TMP(SDS1,$J,SDS2,"VISIT","NWK")*100/SDCT)),8,2)
    38         D:$Y>(IOSL-4) XHDR Q:SDOUT  W !?10,"Transmitted, accepted visits",?47,$J(^TMP(SDS1,$J,SDS2,"VISIT","OWK"),12),?62,$J($S(SDCT=0:0,1:(^TMP(SDS1,$J,SDS2,"VISIT","OWK")*100/SDCT)),8,2)
    39         D TOT
    40         W !! D SHDR(($$HD2()_"   O U T P A T I E N T   U N I Q U E S")) Q:SDOUT
    41         S SDUNCO=^TMP(SDS1,$J,SDS2,"UNIQUE","UNCO"),SDUNAR=^TMP(SDS1,$J,SDS2,"UNIQUE","UNAR"),SDCT=SDUNCO+SDUNAR
    42         D:$Y>(IOSL-4) XHDR Q:SDOUT  W !?10,"Act. Req./not accepted unique pts.",?47,$J(SDUNAR,12),?62,$J($S(SDCT=0:0,1:SDUNAR*100/SDCT),8,2)
    43         D:$Y>(IOSL-4) XHDR Q:SDOUT  W !?10,"Transmitted, accepted unique pts.",?47,$J(SDUNCO,12),?62,$J($S(SDCT=0:0,1:SDUNCO*100/SDCT),8,2) D TOT
    44         Q
    45         ;
    46 XHDR    I $E(IOST)="C",SDPAGE>1 N DIR S DIR(0)="E" D ^DIR S SDOUT=Y'=1 Q:SDOUT
    47         S SDLINE="",$P(SDLINE,"-",81)="" W:SDPAGE>1!($E(IOST)="C") $$XY^SCRPW50(IOF,1,0) W:$X $$XY^SCRPW50("",0,0) W SDLINE,!?15,"<*>  OUTPATIENT ENCOUNTER WORKLOAD STATISTICS  <*>"
    48         I $D(^TMP("SCRPW",$J)) S X=$$HD1() W !?(80-$L(X)\2),X
    49         W !,SDLINE,!,"For encounter dates ",SDDTPF," to ",SDDTPL,!,"Date printed: ",SDPNOW,?(74-$L(SDPAGE)),"Page: ",SDPAGE,!,SDLINE,! S SDPAGE=SDPAGE+1
    50         Q
    51         ;
    52 EXIT    K SDTOE0,SDUNCO,SDUNAR,SDCT,DFN,SDDT,SDDTF,SDDTL,SDDTPF,SDDTPL,SDI,SDLINE,SDOE,SDOE0,SDPNOW,SDSTAT,SDSTX,SDTOE,SDTOEE,SDTOE1,SDTX,SDTXS,SDX,SDZ,DTOUT,X,Y,ZTDESC,ZTRTN,ZTSAVE
    53         D KVA^VADPT K X1,X2,SDH,SDHL,SDPNAM,SDSSN,SDPAGE,SDPT0,SDUL,DUOUT,SDARCT,SDST,SDPNOW,SDMD,SDMC,SDDIV,SDDNAM,SDS1,SDS2,SDCG,SDCLGR F I="SCRPW","SCRPWD","SCRPWC" K ^TMP(I,$J)
    54         K I,SDFF,SDOUT,SDSTOP,SDNCOU D END^SCRPW50 Q
    55         ;
    56 HD1()   ;Report subheader 1
    57         Q $S(SDS1="SCRPW":"For station: ",SDS1="SCRPWD":"For division: ",1:"For clinic group: ")_SDS2
    58         ;
    59 HD2()   ;Report subheader 2
    60         Q $S(SDS1="SCRPW":"F A C I L I T Y",SDS1="SCRPWD":"D I V I S I O N",1:"C L I N I C   G R O U P")
    61         ;
    62 DIV()   ;Return division name
    63         N X S X=$P($G(^DG(40.8,+$P(SDOE0,U,11),0)),U) Q $S('$L(X):"***UNKNOWN***",1:X)
    64         ;
    65 CLGR()  ;Return CLINIC GROUP pointer
    66         N X S X=$P($G(^SC(+$P(SDOE0,U,4),0)),U,31),X=$P($G(^SD(409.67,+X,0)),U) Q $S('$L(X):"***NONE ASSIGNED***",1:X)
    67         ;
    68 NCT1    I '$D(^TMP(SDS1,$J,SDS2,"VISIT","ACC",DFN)) S SDUNAR=SDUNAR+1 D:SDUL&(SDS1="SCRPW") UL("OWK")
    69         S SDDT=0 F  S SDDT=$O(^TMP(SDS1,$J,SDS2,"VISIT","OWK",DFN,SDDT)) Q:'SDDT  I '$D(^TMP(SDS1,$J,SDS2,"VISIT","ACC",DFN,SDDT)) S SDCT=SDCT+1
    70         Q
    71         ;
    72 CT1     I '$D(^TMP(SDS1,$J,SDS2,"VISIT","OWK",DFN)),'$D(^TMP(SDS1,$J,SDS2,"VISIT","ACC",DFN)) S SDUNAR=SDUNAR+1 D:SDUL&(SDS1="SCRPW") UL("NWK")
    73         S SDDT=0 F  S SDDT=$O(^TMP(SDS1,$J,SDS2,"VISIT","NWK",DFN,SDDT)) Q:'SDDT  I '$D(^TMP(SDS1,$J,SDS2,"VISIT","OWK",DFN,SDDT)),'$D(^TMP(SDS1,$J,SDS2,"VISIT","ACC",DFN,SDDT)) S SDCT=SDCT+1
    74         Q
    75         ;
    76 UL(SDI) D ^VADPT S SDDT=0 F  S SDDT=$O(^TMP(SDS1,$J,SDS2,"VISIT",SDI,DFN,SDDT)) Q:'SDDT  S ^TMP(SDS1,$J,SDS2,"VISIT","UNARL",VADM(1),DFN,$P(VADM(2),U),SDDT)=""
    77         Q
    78         ;
    79 TOT     W !?47,"============  =========",!?39,"TOTAL:",?47,$J(SDCT,12),?64,"100.00" Q
    80         ;
    81 SHDR(SDTX)      D:$Y>(IOSL-6) XHDR Q:SDOUT  W !!?(80-$L(SDTX)\2),SDTX,!?(80-$L(SDTX)\2) F SDX=1:1:$L(SDTX) W "-"
    82         W !!?39,"Status",?54,"Count",?63,"Percent",!?10,"-----------------------------------  ------------  ---------" Q
    83         ;
    84 LIST(SDI)       Q:'$D(^TMP(SDS1,$J,SDS2,SDI))  D:$Y>(IOSL-4) XHDR Q:SDOUT
    85         W !?10,$P(^SD(409.63,+SDI,0),U),?47,$J(^TMP(SDS1,$J,SDS2,SDI),12),?62,$J($S(SDCT=0:0,1:(^TMP(SDS1,$J,SDS2,SDI)*100/SDCT)),8,2)
    86         Q
    87         ;
    88 COT     D:$Y>(IOSL-4) XHDR Q:SDOUT  W !?15,SDSTAT,?47,$J(^TMP(SDS1,$J,SDS2,2,SDI,SDSTAT),12),?62,$J($S(SDCT=0:0,1:(^TMP(SDS1,$J,SDS2,2,SDI,SDSTAT)*100/SDCT)),8,2) Q
    89         ;
    90 IAP     D:$Y>(IOSL-4) XHDR Q:SDOUT  W !?15,SDSTAT,?47,$J(^TMP(SDS1,$J,SDS2,"8-CC",SDI,SDSTAT),12),?62,$J($S(SDCT=0:0,1:(^TMP(SDS1,$J,SDS2,"8-CC",SDI,SDSTAT)*100/SDCT)),8,2) Q
    91 STOP    ;Check for stop task request
    92         S:$G(ZTQUEUED) (SDOUT,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q
    93         ;
    94 COUNT   ;Count encounters
    95         S SDNCOU=$P($G(^SC(+$P(SDOE0,U,4),0)),U,17),SDNCOU=$S(SDNCOU="Y":1,1:0)
    96         S SDSTOP=SDSTOP+1 I SDSTOP#3000=0 D STOP Q:SDOUT
    97         D C1("SCRPW",SDDNAM) D:SDMD C1("SCRPWD",SDDIV) D:SDCLGR C1("SCRPWC",SDCG) Q
    98         ;
    99 C1(SDS1,SDS2)   ;Set ^TMP global
    100         ;Required input: SDS1,SDS2=subscript values
    101         ;Because there is only 1 status (8) for INPATIENTS, 8-NC is used to
    102         ;distinguish the non-count clinics from the count clinics, 8-CC.
    103         S DFN=$P(SDOE0,U,2),SDSTAT=+$P(SDOE0,U,12) I SDSTAT=8 S SDSTAT=$S(SDNCOU:SDSTAT_"-NC",1:SDSTAT_"-CC")
    104         I SDZ(0),SDZ(4)=SDDIV,SDS1="SCRPW" D DETAIL
    105         S ^TMP(SDS1,$J,SDS2,SDSTAT)=$G(^TMP(SDS1,$J,SDS2,SDSTAT))+1
    106         Q:SDSTAT=4  Q:(+SDSTAT=8)&($P(SDSTAT,"-",2)="NC")  D:"114238"[+SDSTAT VIS Q
    107         ;
    108 VIS     S ^TMP(SDS1,$J,SDS2,"VISIT",$S(SDSTAT=2:"OWK",(+SDSTAT=8)&('SDNCOU):"OWK",1:"NWK"),DFN,$P(SDDT,"."))="" Q:(+SDSTAT'=2)&(+SDSTAT'=8)
    109         I +SDSTAT=8,$P(SDOE0,U,7)="" D  Q
    110         .S ^TMP(SDS1,$J,SDS2,SDSTAT,10,"Action Required")=$G(^TMP(SDS1,$J,SDS2,SDSTAT,10,"Action Required"))+1
    111         S SDSTX=$$STX(SDOE,SDOE0),^TMP(SDS1,$J,SDS2,SDSTAT,$P(SDSTX,U),$P(SDSTX,U,2))=$G(^TMP(SDS1,$J,SDS2,SDSTAT,$P(SDSTX,U),$P(SDSTX,U,2)))+1
    112         Q:$P(SDSTX,U)'=8  S ^TMP(SDS1,$J,SDS2,"VISIT","ACC",DFN,$P(SDDT,"."))=""
    113         Q
    114         ;
    115 STX(SDOE,SDOE0) ;Determine transmission status
    116         ;Required input: SDOE=OUTPATIENT ENCOUNTER record IFN
    117         ;Required input: SDOE0=zeroeth node of OUTPATIENT ENCOUNTER
    118         N SDTOE,SDTOEE
    119         Q:($P(SDOE0,U,12)'=2)&($P(SDOE0,U,12)'=8) "0^Not checked-out^Not checked-out"
    120         S SDTOE=$O(^SD(409.73,"AENC",SDOE,0)) Q:'SDTOE!'$D(^SD(409.73,+SDTOE,0)) "1^No transmission record^No tx. record"
    121         S SDTOE1=$G(^SD(409.73,SDTOE,1)),SDTOE0=^SD(409.73,SDTOE,0) I '$P(SDTOE0,U,4),'$P(SDTOE1,U) Q "2^Not required, not transmitted^Not req., not tx."
    122         ; SD*5.3*339 added second I SDTOEE below
    123         S SDTOEE=$O(^SD(409.75,"B",SDTOE,0)) I SDTOEE S SDTOEE=$P($G(^SD(409.75,SDTOEE,0)),U,2) I SDTOEE S SDTOEE=$P($G(^SD(409.76,SDTOEE,0)),U,2) Q:SDTOEE="V" "3^Rejected for transmission^Rejected for tx."
    124         Q:'$P(SDTOE1,U) "4^Awaiting transmission^Awaiting tx."
    125         S SDTXS=$P(SDTOE1,U,5) Q:'$L(SDTXS) "5^Transmitted, no acknowledgment^Tx., no ack."
    126         Q:SDTXS="R" "6^Transmitted, rejected^Tx., rejected"
    127         Q:SDTXS'="A" "7^Transmitted, error^Tx., error"
    128         Q "8^Transmitted, accepted^Tx., accepted"
    129         ;
    130 DETAIL  ;Set global for detailed list
    131         N SDIF S SDIF=0
    132         D ^VADPT S SDPNAM=VADM(1),SDSSN=$P(VADM(2),U)
    133         I SDZ(1)="U",+SDSTAT'=4,'SDNCOU S:"114238"[+SDSTAT ^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,SDSSN)="" Q
    134         I SDZ(1)="V",+SDSTAT'=4,'SDNCOU S:"114238"[+SDSTAT ^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,SDSSN,$P(SDDT,"."))="" Q
    135         Q:'$D(SDZ(2))  ; SD*5.3*339
    136         I SDZ(2)'=2,SDZ(2)=+SDSTAT D  I SDIF Q
    137         .I (SDZ(2)=8) Q:$P(SDSTAT,"-",2)="CC"  I SDZ(3)'=9 S SDIF=1 Q
    138         .D DSET S SDIF=1
    139         Q:("28"'[SDZ(2))!("28"'[+SDSTAT)  Q:SDZ(2)'=+SDSTAT  D  I SDIF Q
    140         .I +SDSTAT=8,$P(SDSTAT,"-",2)="NC" S SDIF=1 Q
    141         .I 'SDZ(3) D DSET S SDIF=1
    142         D:+$$STX(SDOE,SDOE0)=SDZ(3) DSET Q
    143         ;
    144 DSET    S ^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,SDSSN,SDDT,SDOE)=+$P(SDOE0,U,4) Q
     1SCRPW8 ;RENO/KEITH - Outpatient Encounter Workload Statistics ; 04 Feb 99  4:53 PM
     2 ;;5.3;Scheduling;**139,145,144,176,339,466**;AUG 13, 1993;Build 2
     3QS ;Queue outpatient encounter workload report
     4 D PARM^SCRPW9 Q
     5 ;
     6PST ;Print stats
     7 N X,Y,%
     8 D NOW^%DTC S Y=% X ^DD("DD") S SDPAGE=1,SDPNOW=$P(Y,":",1,2),SDDT=SDDTF,SDMC=$O(^DG(43,0)),SDMC=$G(^DG(43,+SDMC,"GL")),SDMD=$P(SDMC,U,2),(SDOUT,SDSTOP,SDFF)=0
     9 S SDDNAM=$P($G(^DG(40.8,+$$PRIM^VASITE(),0)),U,7),SDDNAM=$$GET1^DIQ(4,+SDDNAM,.01) S:'$L(SDDNAM) SDDNAM=$P($G(^DG(40.8,+$P(SDMC,U,3),0)),U)
     10 F I="SCRPW","SCRPWD","SCRPWC" K ^TMP(I,$J)
     11 F  S SDDT=$O(^SCE("B",SDDT)) Q:'SDDT!(SDDT>SDDTL)!SDOUT  S SDOE=0 D
     12 .F  S SDOE=$O(^SCE("B",SDDT,SDOE)) Q:'SDOE!SDOUT  S SDOE0=$$GETOE^SDOE(SDOE) I $L(SDOE0),'$P(SDOE0,U,6),$P(SDOE0,U,2),$P(SDOE0,U,11),$P(SDOE0,U,12) S SDDIV=$$DIV(),SDCG=$$CLGR() D COUNT
     13 .Q
     14 I '$D(^TMP("SCRPW",$J)) D XHDR S SDX="No activity found within the parameters specified." W !!?(80-$L(SDX)\2),SDX G EXIT
     15 F SDS1="SCRPW","SCRPWD","SCRPWC" S SDS2="" F  S SDS2=$O(^TMP(SDS1,$J,SDS2)) Q:SDS2=""!SDOUT  D STCT
     16 G:SDOUT EXIT D:$E(IOST)="C" DISP0^SCRPW23
     17 F SDS1="SCRPW","SCRPWD","SCRPWC" S SDS2="" F  S SDS2=$O(^TMP(SDS1,$J,SDS2)) Q:SDS2=""!SDOUT  D PRPT
     18 G:SDOUT EXIT
     19 D:SDZ(0) DPRT^SCRPW9("SCRPW",SDDNAM) G:SDOUT EXIT D:SDUL UNARL^SCRPW9("SCRPW",SDDNAM) G EXIT
     20 ;
     21STCT S (SDUNCO,SDCT,DFN)=0 D STOP Q:SDOUT
     22 F  S DFN=$O(^TMP(SDS1,$J,SDS2,"VISIT","ACC",DFN)) Q:'DFN  S SDUNCO=SDUNCO+1,SDDT=0 F  S SDDT=$O(^TMP(SDS1,$J,SDS2,"VISIT","ACC",DFN,SDDT)) Q:'SDDT  S SDCT=SDCT+1
     23 S ^TMP(SDS1,$J,SDS2,"UNIQUE","UNCO")=SDUNCO,^TMP(SDS1,$J,SDS2,"VISIT","OWK")=SDCT,(SDUNAR,SDCT,DFN)=0
     24 S DFN=0 F  S DFN=$O(^TMP(SDS1,$J,SDS2,"VISIT","OWK",DFN)) Q:'DFN  D NCT1
     25 S DFN=0 F  S DFN=$O(^TMP(SDS1,$J,SDS2,"VISIT","NWK",DFN)) Q:'DFN  D CT1
     26 S ^TMP(SDS1,$J,SDS2,"UNIQUE","UNAR")=SDUNAR,^TMP(SDS1,$J,SDS2,"VISIT","NWK")=SDCT Q
     27 ;
     28PRPT ;Print statistics page
     29 D STOP Q:SDOUT
     30 S SDCT=0 F SDI=1,2,3,11,14,8 S SDCT=SDCT+$G(^TMP(SDS1,$J,SDS2,SDI))
     31 D XHDR Q:SDOUT  D SHDR("O U T P A T I E N T   E N C O U N T E R   W O R K L O A D") Q:SDOUT  F SDI=11,14,3,1 D LIST(SDI) Q:SDOUT
     32 I $D(^TMP(SDS1,$J,SDS2,2)) D:$Y>(IOSL-4) XHDR Q:SDOUT  W !?10,"CHECKED OUT" S SDI=0 F  S SDI=$O(^TMP(SDS1,$J,SDS2,2,SDI)) Q:'SDI!SDOUT  S SDSTAT=$O(^TMP(SDS1,$J,SDS2,2,SDI,"")) D COT
     33 I $D(^TMP(SDS1,$J,SDS2,8)) D:$Y>(IOSL-4) XHDR Q:SDOUT  W !?10,"INPATIENT APPOINTMENT" S SDI=0 F  S SDI=$O(^TMP(SDS1,$J,SDS2,8,SDI)) Q:'SDI!SDOUT  S SDSTAT=$O(^TMP(SDS1,$J,SDS2,8,SDI,"")) D IAP
     34 D TOT S (SDI,SDCT)=0 F SDI=4,5,6,7,9,12,13 S SDCT=SDCT+$G(^TMP(SDS1,$J,SDS2,SDI))
     35 W !! D SHDR("N O N - W O R K L O A D") Q:SDOUT  F SDI=12,4,6,5,7,9,10,13 D LIST(SDI) Q:SDOUT
     36 D TOT W !! D SHDR(($$HD2()_"   O U T P A T I E N T   V I S I T S")) Q:SDOUT  S SDCT=^TMP(SDS1,$J,SDS2,"VISIT","NWK")+^TMP(SDS1,$J,SDS2,"VISIT","OWK")
     37 D:$Y>(IOSL-4) XHDR Q:SDOUT  W !?10,"Act. Req./not accepted visits",?47,$J(^TMP(SDS1,$J,SDS2,"VISIT","NWK"),12),?62,$J($S(SDCT=0:0,1:(^TMP(SDS1,$J,SDS2,"VISIT","NWK")*100/SDCT)),8,2)
     38 D:$Y>(IOSL-4) XHDR Q:SDOUT  W !?10,"Transmitted, accepted visits",?47,$J(^TMP(SDS1,$J,SDS2,"VISIT","OWK"),12),?62,$J($S(SDCT=0:0,1:(^TMP(SDS1,$J,SDS2,"VISIT","OWK")*100/SDCT)),8,2)
     39 D TOT
     40 W !! D SHDR(($$HD2()_"   O U T P A T I E N T   U N I Q U E S")) Q:SDOUT
     41 S SDUNCO=^TMP(SDS1,$J,SDS2,"UNIQUE","UNCO"),SDUNAR=^TMP(SDS1,$J,SDS2,"UNIQUE","UNAR"),SDCT=SDUNCO+SDUNAR
     42 D:$Y>(IOSL-4) XHDR Q:SDOUT  W !?10,"Act. Req./not accepted unique pts.",?47,$J(SDUNAR,12),?62,$J($S(SDCT=0:0,1:SDUNAR*100/SDCT),8,2)
     43 D:$Y>(IOSL-4) XHDR Q:SDOUT  W !?10,"Transmitted, accepted unique pts.",?47,$J(SDUNCO,12),?62,$J($S(SDCT=0:0,1:SDUNCO*100/SDCT),8,2) D TOT
     44 Q
     45 ;
     46XHDR I $E(IOST)="C",SDPAGE>1 N DIR S DIR(0)="E" D ^DIR S SDOUT=Y'=1 Q:SDOUT
     47 S SDLINE="",$P(SDLINE,"-",81)="" W:SDPAGE>1!($E(IOST)="C") $$XY^SCRPW50(IOF,1,0) W:$X $$XY^SCRPW50("",0,0) W SDLINE,!?15,"<*>  OUTPATIENT ENCOUNTER WORKLOAD STATISTICS  <*>"
     48 I $D(^TMP("SCRPW",$J)) S X=$$HD1() W !?(80-$L(X)\2),X
     49 W !,SDLINE,!,"For encounter dates ",SDDTPF," to ",SDDTPL,!,"Date printed: ",SDPNOW,?(74-$L(SDPAGE)),"Page: ",SDPAGE,!,SDLINE,! S SDPAGE=SDPAGE+1
     50 Q
     51 ;
     52EXIT K SDTOE0,SDUNCO,SDUNAR,SDCT,DFN,SDDT,SDDTF,SDDTL,SDDTPF,SDDTPL,SDI,SDLINE,SDOE,SDOE0,SDPNOW,SDSTAT,SDSTX,SDTOE,SDTOEE,SDTOE1,SDTX,SDTXS,SDX,SDZ,DTOUT,X,Y,ZTDESC,ZTRTN,ZTSAVE
     53 D KVA^VADPT K X1,X2,SDH,SDHL,SDPNAM,SDSSN,SDPAGE,SDPT0,SDUL,DUOUT,SDARCT,SDST,SDPNOW,SDMD,SDMC,SDDIV,SDDNAM,SDS1,SDS2,SDCG,SDCLGR F I="SCRPW","SCRPWD","SCRPWC" K ^TMP(I,$J)
     54 K I,SDFF,SDOUT,SDSTOP D END^SCRPW50 Q
     55 ;
     56HD1() ;Report subheader 1
     57 Q $S(SDS1="SCRPW":"For station: ",SDS1="SCRPWD":"For division: ",1:"For clinic group: ")_SDS2
     58 ;
     59HD2() ;Report subheader 2
     60 Q $S(SDS1="SCRPW":"F A C I L I T Y",SDS1="SCRPWD":"D I V I S I O N",1:"C L I N I C   G R O U P")
     61 ;
     62DIV() ;Return division name
     63 N X S X=$P($G(^DG(40.8,+$P(SDOE0,U,11),0)),U) Q $S('$L(X):"***UNKNOWN***",1:X)
     64 ;
     65CLGR() ;Return CLINIC GROUP pointer
     66 N X S X=$P($G(^SC(+$P(SDOE0,U,4),0)),U,31),X=$P($G(^SD(409.67,+X,0)),U) Q $S('$L(X):"***NONE ASSIGNED***",1:X)
     67 ;
     68NCT1 I '$D(^TMP(SDS1,$J,SDS2,"VISIT","ACC",DFN)) S SDUNAR=SDUNAR+1 D:SDUL&(SDS1="SCRPW") UL("OWK")
     69 S SDDT=0 F  S SDDT=$O(^TMP(SDS1,$J,SDS2,"VISIT","OWK",DFN,SDDT)) Q:'SDDT  I '$D(^TMP(SDS1,$J,SDS2,"VISIT","ACC",DFN,SDDT)) S SDCT=SDCT+1
     70 Q
     71 ;
     72CT1 I '$D(^TMP(SDS1,$J,SDS2,"VISIT","OWK",DFN)),'$D(^TMP(SDS1,$J,SDS2,"VISIT","ACC",DFN)) S SDUNAR=SDUNAR+1 D:SDUL&(SDS1="SCRPW") UL("NWK")
     73 S SDDT=0 F  S SDDT=$O(^TMP(SDS1,$J,SDS2,"VISIT","NWK",DFN,SDDT)) Q:'SDDT  I '$D(^TMP(SDS1,$J,SDS2,"VISIT","OWK",DFN,SDDT)),'$D(^TMP(SDS1,$J,SDS2,"VISIT","ACC",DFN,SDDT)) S SDCT=SDCT+1
     74 Q
     75 ;
     76UL(SDI) D ^VADPT S SDDT=0 F  S SDDT=$O(^TMP(SDS1,$J,SDS2,"VISIT",SDI,DFN,SDDT)) Q:'SDDT  S ^TMP(SDS1,$J,SDS2,"VISIT","UNARL",VADM(1),DFN,$P(VADM(2),U),SDDT)=""
     77 Q
     78 ;
     79TOT W !?47,"============  =========",!?39,"TOTAL:",?47,$J(SDCT,12),?64,"100.00" Q
     80 ;
     81SHDR(SDTX) D:$Y>(IOSL-6) XHDR Q:SDOUT  W !!?(80-$L(SDTX)\2),SDTX,!?(80-$L(SDTX)\2) F SDX=1:1:$L(SDTX) W "-"
     82 W !!?39,"Status",?54,"Count",?63,"Percent",!?10,"-----------------------------------  ------------  ---------" Q
     83 ;
     84LIST(SDI) Q:'$D(^TMP(SDS1,$J,SDS2,SDI))  D:$Y>(IOSL-4) XHDR Q:SDOUT
     85 W !?10,$P(^SD(409.63,SDI,0),U),?47,$J(^TMP(SDS1,$J,SDS2,SDI),12),?62,$J($S(SDCT=0:0,1:(^TMP(SDS1,$J,SDS2,SDI)*100/SDCT)),8,2)
     86 Q
     87 ;
     88COT D:$Y>(IOSL-4) XHDR Q:SDOUT  W !?15,SDSTAT,?47,$J(^TMP(SDS1,$J,SDS2,2,SDI,SDSTAT),12),?62,$J($S(SDCT=0:0,1:(^TMP(SDS1,$J,SDS2,2,SDI,SDSTAT)*100/SDCT)),8,2) Q
     89 ;
     90IAP D:$Y>(IOSL-4) XHDR Q:SDOUT  W !?15,SDSTAT,?47,$J(^TMP(SDS1,$J,SDS2,8,SDI,SDSTAT),12),?62,$J($S(SDCT=0:0,1:(^TMP(SDS1,$J,SDS2,8,SDI,SDSTAT)*100/SDCT)),8,2) Q
     91STOP ;Check for stop task request
     92 S:$G(ZTQUEUED) (SDOUT,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q
     93 ;
     94COUNT ;Count encounters
     95 S SDSTOP=SDSTOP+1 I SDSTOP#3000=0 D STOP Q:SDOUT
     96 D C1("SCRPW",SDDNAM) D:SDMD C1("SCRPWD",SDDIV) D:SDCLGR C1("SCRPWC",SDCG) Q
     97 ;
     98C1(SDS1,SDS2) ;Set ^TMP global
     99 ;Required input: SDS1,SDS2=subscript values
     100 S DFN=$P(SDOE0,U,2),SDSTAT=+$P(SDOE0,U,12) I SDZ(0),SDZ(4)=SDDIV,SDS1="SCRPW" D DETAIL
     101 S ^TMP(SDS1,$J,SDS2,SDSTAT)=$G(^TMP(SDS1,$J,SDS2,SDSTAT))+1
     102 Q:SDSTAT=4  D:"114238"[SDSTAT VIS Q
     103 ;
     104VIS S ^TMP(SDS1,$J,SDS2,"VISIT",$S(SDSTAT=2:"OWK",SDSTAT=8:"OWK",1:"NWK"),DFN,$P(SDDT,"."))="" Q:(SDSTAT'=2)&(SDSTAT'=8)
     105 S SDSTX=$$STX(SDOE,SDOE0),^TMP(SDS1,$J,SDS2,SDSTAT,$P(SDSTX,U),$P(SDSTX,U,2))=$G(^TMP(SDS1,$J,SDS2,SDSTAT,$P(SDSTX,U),$P(SDSTX,U,2)))+1
     106 Q:$P(SDSTX,U)'=8  S ^TMP(SDS1,$J,SDS2,"VISIT","ACC",DFN,$P(SDDT,"."))=""
     107 Q
     108 ;
     109STX(SDOE,SDOE0) ;Determine transmission status
     110 ;Required input: SDOE=OUTPATIENT ENCOUNTER record IFN
     111 ;Required input: SDOE0=zeroeth node of OUTPATIENT ENCOUNTER
     112 N SDTOE,SDTOEE
     113 Q:($P(SDOE0,U,12)'=2)&($P(SDOE0,U,12)'=8) "0^Not checked-out^Not checked-out"
     114 S SDTOE=$O(^SD(409.73,"AENC",SDOE,0)) Q:'SDTOE!'$D(^SD(409.73,+SDTOE,0)) "1^No transmission record^No tx. record"
     115 S SDTOE1=$G(^SD(409.73,SDTOE,1)),SDTOE0=^SD(409.73,SDTOE,0) I '$P(SDTOE0,U,4),'$P(SDTOE1,U) Q "2^Not required, not transmitted^Not req., not tx."
     116 ; SD*5.3*339 added second I SDTOEE below
     117 S SDTOEE=$O(^SD(409.75,"B",SDTOE,0)) I SDTOEE S SDTOEE=$P($G(^SD(409.75,SDTOEE,0)),U,2) I SDTOEE S SDTOEE=$P($G(^SD(409.76,SDTOEE,0)),U,2) Q:SDTOEE="V" "3^Rejected for transmission^Rejected for tx."
     118 Q:'$P(SDTOE1,U) "4^Awaiting transmission^Awaiting tx."
     119 S SDTXS=$P(SDTOE1,U,5) Q:'$L(SDTXS) "5^Transmitted, no acknowledgment^Tx., no ack."
     120 Q:SDTXS="R" "6^Transmitted, rejected^Tx., rejected"
     121 Q:SDTXS'="A" "7^Transmitted, error^Tx., error"
     122 Q "8^Transmitted, accepted^Tx., accepted"
     123 ;
     124DETAIL ;Set global for detailed list
     125 D ^VADPT S SDPNAM=VADM(1),SDSSN=$P(VADM(2),U)
     126 I SDZ(1)="U",SDSTAT'=4 S:"114238"[SDSTAT ^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,SDSSN)="" Q
     127 I SDZ(1)="V",SDSTAT'=4 S:"114238"[SDSTAT ^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,SDSSN,$P(SDDT,"."))="" Q
     128 Q:'$D(SDZ(2))  ; SD*5.3*339
     129 I (SDZ(2)'=2)&(SDZ(2)'=8),SDZ(2)=SDSTAT D DSET Q
     130 Q:("28"'[SDZ(2))!("28"'[SDSTAT)!(SDZ(2)'=SDSTAT)  I 'SDZ(3) D DSET Q
     131 D:+$$STX(SDOE,SDOE0)=SDZ(3) DSET Q
     132 ;
     133DSET S ^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,SDSSN,SDDT,SDOE)=+$P(SDOE0,U,4) Q

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPW9.m

    r613 r623  
    1 SCRPW9  ;RENO/KEITH - Outpatient Encounter Workload Statistics (cont.) ; 15 Jul 98  02:38PM
    2         ;;5.3;Scheduling;**139,144,339,466,510**;AUG 13, 1993;Build 3
    3 UNARL(SDS1,SDS2)        ;Print list of 'action required'/not accepted uniques
    4         ;Required input: SDS1,SDS2=subscript values
    5         S SDPAGE=1 D UHDR Q:SDOUT  I '$D(^TMP(SDS1,$J,SDS2,"VISIT","UNARL")) W !!,"No 'action required'/not accepted unique patients identified." Q
    6         S SDARCT=0,SDPNAM="" F  S SDPNAM=$O(^TMP(SDS1,$J,SDS2,"VISIT","UNARL",SDPNAM)) Q:SDPNAM=""!SDOUT  S DFN=0 F  S DFN=$O(^TMP(SDS1,$J,SDS2,"VISIT","UNARL",SDPNAM,DFN)) Q:'DFN!SDOUT  D UNP
    7         Q:SDOUT  D:$Y>(IOSL-3) UHDR Q:SDOUT  W !!,SDARCT," 'action required'/not accepted unique patient",$S(SDARCT=1:"",1:"s")," identified." Q
    8         ;
    9 UNP     S SDSSN=$O(^TMP(SDS1,$J,SDS2,"VISIT","UNARL",SDPNAM,DFN,"")) D:$Y>(IOSL-4) UHDR Q:SDOUT  W !,$E(SDPNAM,1,18),?20,SDSSN
    10         S SDARCT=SDARCT+1,(SDDT,SDI)=0 F  S SDDT=$O(^TMP(SDS1,$J,SDS2,"VISIT","UNARL",SDPNAM,DFN,SDSSN,SDDT)) Q:'SDDT!SDOUT  D:$Y>(IOSL-4) UHDR Q:SDOUT  S Y=SDDT X ^DD("DD") W:SDI ! W ?31,Y S SDI=1 D UNP1
    11         Q
    12         ;
    13 UNP1    N SDII,SDDT1 S SDII=0,SDDT1=SDDT F  S SDDT1=$O(^SCE("ADFN",DFN,SDDT1)) Q:'SDDT1!(SDDT1>(SDDT+.9999))!SDOUT  D
    14         .S SDOE=0 F  S SDOE=$O(^SCE("ADFN",DFN,SDDT1,SDOE)) Q:'SDOE!SDOUT  S SDOE0=$$GETOE^SDOE(SDOE) I $L(SDOE0),'$P(SDOE0,U,6) D UNP2
    15         .Q
    16         Q
    17         ;
    18 UNP2    N SDCL,SDST Q:'$P(SDOE0,U,4)  S SDCL=$P($G(^SC($P(SDOE0,U,4),0)),U),SDST=$P(SDOE0,U,12) Q:$P($G(^SC($P(SDOE0,U,4),0)),U,17)="Y"  Q:'SDST!(SDST=12)  S SDST=$S("28"'[SDST:$P(^SD(409.63,SDST,0),U),1:$P($$STX^SCRPW8(SDOE,SDOE0),U,3))
    19         D:$Y>(IOSL-4) UHDR Q:SDOUT  W:SDII ! W ?44,$E(SDCL,1,17),?63,$E(SDST,1,17) S SDII=SDII+1 Q
    20         ;
    21 UHDR    I $E(IOST)="C" N DIR S DIR(0)="E" D ^DIR S SDOUT=Y'=1 Q:SDOUT
    22         D STOP^SCRPW8 Q:SDOUT
    23         W $$XY^SCRPW50(IOF,1,0),SDLINE,!?8,"<*>  LIST OF 'ACTION REQUIRED'/NOT ACCEPTED UNIQUE PATIENTS  <*>",!?(66-$L(SDDNAM)\2),"For station: ",SDDNAM
    24         W !,SDLINE,!,"For encounter dates ",SDDTPF," to ",SDDTPL,!,"Date printed: ",SDPNOW,?(74-$L(SDPAGE)),"Page: ",SDPAGE,!,SDLINE,! S SDPAGE=SDPAGE+1
    25         W:$D(^TMP(SDS1,$J,SDS2,"VISIT","UNARL")) !,"Name:",?20,"SSN:",?31,"Date:",?44,"Location:",?63,"Reason:",! Q
    26         ;
    27 DETAIL  ;Ask questions for detail of encounters or uniques for a division
    28         K SDZ S SDZ(0)=0 K DIR S DIR(0)="Y",DIR("A")="Would you like to print a detailed list of activity for a division",DIR("B")="NO" W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDZ(0)=-1 Q
    29         S SDZ(0)=Y Q:'Y  W !!!,$C(7),"   WARNING: Selection high activity areas will result in lengthy output!",!
    30         K DIR S DIR(0)="S^U:UNIQUES;V:VISITS;E:ENCOUNTERS",DIR("A")="Select type of list" D ^DIR I $D(DTOUT)!$D(DUOUT) S SDZ(0)=-1 Q
    31         S SDZ(1)=Y G:Y'="E" ZDIV
    32 DET1    K DIC S DIC="^SD(409.63,",DIC(0)="AEMQ",DIC("S")="I Y<4!(Y=8!(Y=12!(Y=14)))",DIC("A")="Select encounter status: " W ! D ^DIC I $D(DTOUT)!$D(DUOUT)!($G(Y)<1) S SDZ(0)=-1 Q
    33         S SDZ(2)=$P(Y,U) G:(SDZ(2)'=2)&(SDZ(2)'=8) ZDIV K DIR S DIR("A")="Select transmission status for "_$S(SDZ(2)=2:"CHECKED OUT",1:"INPATIENT APPOINTMENT")_" encounters"
    34         S DIR(0)="S^A:All transmission statuses;1:No transmission record;2:Not required, not transmitted;3:Rejected for transmission;4:Awaiting transmission;"
    35         S DIR(0)=DIR(0)_"5:Transmitted, no acknowledgment;6:Transmitted, rejected;7:Transmitted, error;8:Transmitted, accepted"
    36         I SDZ(2)=8 S DIR(0)=DIR(0)_";9:Non-Count (not transmitted)"
    37         W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDZ(0)=-1 Q  ;SD*5.3*339 add sub-zero
    38         S SDZ(3)=+Y
    39 ZDIV    ;Get division for detail
    40         I '$P($G(^DG(43,1,"GL")),U,2) S SDZ(4)=$P(^DG(40.8,$$PRIM^VASITE(),0),U) Q
    41         K DIC S DIC="^DG(40.8,",DIC("A")="Select Medical Center division for detail: ",DIC(0)="AEMQ" W ! D ^DIC I $D(DTOUT)!$D(DUOUT) S SDZ(0)=-1 Q
    42         I Y<1 W $C(7),"    Required for patient detail!" G ZDIV
    43         S SDZ(4)=$P(Y,U,2) Q
    44         ;
    45 DPRT(SDS1,SDS2) ;Detail print
    46         ;Required input: SDS1,SDS2=subscript values
    47         K SDH S SDPAGE=1,SDH(1)="<*>  DETAILED LIST OF DIVISION "_$S(SDZ(1)="U":"UNIQUES",SDZ(1)="V":"VISITS",1:"ENCOUNTERS")_"  <*>",SDH(2)="For division: "_SDZ(4)
    48         I $G(SDZ(2)) S SDH(3)="Encounters with "_$P(^SD(409.63,SDZ(2),0),U)_" status"
    49         I $G(SDZ(2))'="","28"[SDZ(2) S SDH(4)="Transmission status: "_$P($T(TXS+SDZ(3)),";",2)
    50         D DHDR Q:SDOUT  I '$D(^TMP(SDS1,$J,SDS2,"DETAIL")) W !,"No records found in this category." Q
    51         S SDCT=0 D @SDZ(1) Q
    52         ;
    53 U       ;Print uniques
    54         S SDPNAM="" F  S SDPNAM=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM)) Q:SDPNAM=""!SDOUT  S DFN=0 F  S DFN=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN)) Q:'DFN!SDOUT  D U1
    55         Q:SDOUT  W !!,SDCT," uniques identified." Q
    56         ;
    57 U1      S SDCT=SDCT+1,SDSSN=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,"")) D:$Y>(IOSL-4) DHDR Q:SDOUT  W !,$E(SDPNAM,1,18),?21,SDSSN Q
    58         ;
    59 V       ;Print visits
    60         S SDPNAM="" F  S SDPNAM=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM)) Q:SDPNAM=""!SDOUT  S DFN=0 F  S DFN=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN)) Q:'DFN!SDOUT  S SDSSN=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,"")) D V1
    61         Q:SDOUT  W !!,SDCT," visits identified." Q
    62         ;
    63 V1      D:$Y>(IOSL-4) DHDR Q:SDOUT  W !,$E(SDPNAM,1,18),?21,SDSSN S (SDDT,SDI)=0 F  S SDDT=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,SDSSN,SDDT)) Q:'SDDT!SDOUT  D
    64         .D:$Y>(IOSL-3) DHDR Q:SDOUT  S Y=SDDT X ^DD("DD") W:SDI ! W ?32,Y S SDCT=SDCT+1,SDI=SDI+1
    65         .Q
    66         Q
    67         ;
    68 E       ;Print encounters
    69         S SDPNAM="" F  S SDPNAM=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM)) Q:SDPNAM=""!SDOUT  S DFN=0 F  S DFN=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN)) Q:'DFN!SDOUT  S SDSSN=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,"")) D E1
    70         Q:SDOUT  W !!,SDCT," encounters identified." Q
    71         ;
    72 E1      D:$Y>(IOSL-4) DHDR Q:SDOUT  W !,$E(SDPNAM,1,18),?21,SDSSN
    73         S (SDDT,SDI)=0 F  S SDDT=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,SDSSN,SDDT)) Q:'SDDT!SDOUT  S SDOE=0 F  S SDOE=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,SDSSN,SDDT,SDOE)) Q:'SDOE!SDOUT  D E2
    74         Q
    75         ;
    76 E2      D:$Y>(IOSL-3) DHDR Q:SDOUT  S SDHL=^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,SDSSN,SDDT,SDOE),SDHL=$P($G(^SC(+SDHL,0)),U),Y=SDDT X ^DD("DD") W:SDI ! W ?32,$P(Y,":",1,2),?50,SDHL S SDCT=SDCT+1,SDI=SDI+1 Q
    77         ;
    78 DHDR    I $E(IOST)="C" N DIR S DIR(0)="E" D ^DIR S SDOUT=Y'=1 Q:SDOUT
    79         D STOP^SCRPW8 Q:SDOUT
    80         W $$XY^SCRPW50(IOF,1,0),SDLINE S I=0 F  S I=$O(SDH(I)) Q:'I  W !?(80-$L(SDH(I))\2),SDH(I)
    81         W !,SDLINE,!,"For date range: ",SDDTPF," to ",SDDTPL,!,"Date printed: ",SDPNOW,?(74-$L(SDPAGE)),"Page: ",SDPAGE,!,SDLINE,! S SDPAGE=SDPAGE+1 Q
    82         ;
    83 TXS     ;All transmission statuses
    84         ;No transmission record
    85         ;Not required, not transmitted
    86         ;Rejected for transmission
    87         ;Awaiting transmission
    88         ;Transmitted, no acknowledgment
    89         ;Transmitted, rejected
    90         ;Transmitted, error
    91         ;Transmitted, accepted
    92         ;Non-Count (not transmitted)
    93         ;
    94 PARM    ;Prompt for report parameters
    95         D TITL^SCRPW50("Outpatient Encounter Workload Statistics")
    96         N %DT,DIR,DIC D SUBT^SCRPW50("*** Date Range Selection ***")
    97 FDT     W ! S %DT="AEPX",%DT("A")="Beginning date:  FIRST// ",%DT(0)=2961001 D ^%DT G:X=U!$D(DTOUT) EXIT^SCRPW8 I X="" S (Y,SDDTF)=2961001 X ^DD("DD") W "  ",Y,! S SDDTPF=Y G LDT
    98         G:Y<1 FDT S SDDTF=Y X ^DD("DD") S SDDTPF=Y W !
    99 LDT     S %DT("A")="Ending date:  LAST// " D ^%DT G:X=U!$D(DTOUT) EXIT^SCRPW8 I X="" S X1=DT,X2=-1 D C^%DTC S (Y,SDDTL)=X X ^DD("DD") W "  ",Y,! S SDDTPL=Y G ASK
    100         I Y<SDDTF W !!,$C(7),"Ending date must be after beginning date!",! G LDT
    101         G:Y<1 LDT S SDDTL=Y X ^DD("DD") S SDDTPL=Y,SDDTL=SDDTL_".999999"
    102 ASK     D SUBT^SCRPW50("*** Additional Detail Selection ***")
    103         W ! K DIR S DIR(0)="Y",DIR("A")="Break out workload by clinic group",DIR("B")="NO",DIR("?")="Specify if subtotals by encounter location CLINIC GROUP should be provided." D ^DIR G:$D(DTOUT)!$D(DUOUT) EXIT^SCRPW8 S SDCLGR=Y
    104         D DETAIL^SCRPW9 W ! G:SDZ(0)=-1 EXIT^SCRPW8
    105         K DIR S DIR(0)="Y",DIR("A")="List facility 'action required'/not accepted unique patients",DIR("B")="NO" D ^DIR G:$D(DTOUT)!$D(DUOUT) EXIT^SCRPW8 S SDUL=Y W !
    106 QUE     S ZTRTN="PST^SCRPW8",ZTDESC="Outpatient Encounter Workload" F SDI="SDCLGR","SDDTF","SDDTPF","SDDTL","SDDTPL","SDUL","SDDUL","SDZ(" S ZTSAVE(SDI)=""
    107         D EN^XUTMDEVQ(ZTRTN,ZTDESC,.ZTSAVE) G EXIT^SCRPW8
     1SCRPW9 ;RENO/KEITH - Outpatient Encounter Workload Statistics (cont.) ; 15 Jul 98  02:38PM
     2 ;;5.3;Scheduling;**139,144,339,466**;AUG 13, 1993;Build 2
     3UNARL(SDS1,SDS2) ;Print list of 'action required'/not accepted uniques
     4 ;Required input: SDS1,SDS2=subscript values
     5 S SDPAGE=1 D UHDR Q:SDOUT  I '$D(^TMP(SDS1,$J,SDS2,"VISIT","UNARL")) W !!,"No 'action required'/not accepted unique patients identified." Q
     6 S SDARCT=0,SDPNAM="" F  S SDPNAM=$O(^TMP(SDS1,$J,SDS2,"VISIT","UNARL",SDPNAM)) Q:SDPNAM=""!SDOUT  S DFN=0 F  S DFN=$O(^TMP(SDS1,$J,SDS2,"VISIT","UNARL",SDPNAM,DFN)) Q:'DFN!SDOUT  D UNP
     7 Q:SDOUT  D:$Y>(IOSL-3) UHDR Q:SDOUT  W !!,SDARCT," 'action required'/not accepted unique patient",$S(SDARCT=1:"",1:"s")," identified." Q
     8 ;
     9UNP S SDSSN=$O(^TMP(SDS1,$J,SDS2,"VISIT","UNARL",SDPNAM,DFN,"")) D:$Y>(IOSL-4) UHDR Q:SDOUT  W !,$E(SDPNAM,1,18),?20,SDSSN
     10 S SDARCT=SDARCT+1,(SDDT,SDI)=0 F  S SDDT=$O(^TMP(SDS1,$J,SDS2,"VISIT","UNARL",SDPNAM,DFN,SDSSN,SDDT)) Q:'SDDT!SDOUT  D:$Y>(IOSL-4) UHDR Q:SDOUT  S Y=SDDT X ^DD("DD") W:SDI ! W ?31,Y S SDI=1 D UNP1
     11 Q
     12 ;
     13UNP1 N SDII,SDDT1 S SDII=0,SDDT1=SDDT F  S SDDT1=$O(^SCE("ADFN",DFN,SDDT1)) Q:'SDDT1!(SDDT1>(SDDT+.9999))!SDOUT  D
     14 .S SDOE=0 F  S SDOE=$O(^SCE("ADFN",DFN,SDDT1,SDOE)) Q:'SDOE!SDOUT  S SDOE0=$$GETOE^SDOE(SDOE) I $L(SDOE0),'$P(SDOE0,U,6) D UNP2
     15 .Q
     16 Q
     17 ;
     18UNP2 N SDCL,SDST Q:'$P(SDOE0,U,4)  S SDCL=$P($G(^SC($P(SDOE0,U,4),0)),U),SDST=$P(SDOE0,U,12) Q:$P($G(^SC($P(SDOE0,U,4),0)),U,17)="Y"  Q:'SDST!(SDST=12)  S SDST=$S("28"'[SDST:$P(^SD(409.63,SDST,0),U),1:$P($$STX^SCRPW8(SDOE,SDOE0),U,3))
     19 D:$Y>(IOSL-4) UHDR Q:SDOUT  W:SDII ! W ?44,$E(SDCL,1,17),?63,$E(SDST,1,17) S SDII=SDII+1 Q
     20 ;
     21UHDR I $E(IOST)="C" N DIR S DIR(0)="E" D ^DIR S SDOUT=Y'=1 Q:SDOUT
     22 D STOP^SCRPW8 Q:SDOUT
     23 W $$XY^SCRPW50(IOF,1,0),SDLINE,!?8,"<*>  LIST OF 'ACTION REQUIRED'/NOT ACCEPTED UNIQUE PATIENTS  <*>",!?(66-$L(SDDNAM)\2),"For station: ",SDDNAM
     24 W !,SDLINE,!,"For encounter dates ",SDDTPF," to ",SDDTPL,!,"Date printed: ",SDPNOW,?(74-$L(SDPAGE)),"Page: ",SDPAGE,!,SDLINE,! S SDPAGE=SDPAGE+1
     25 W:$D(^TMP(SDS1,$J,SDS2,"VISIT","UNARL")) !,"Name:",?20,"SSN:",?31,"Date:",?44,"Location:",?63,"Reason:",! Q
     26 ;
     27DETAIL ;Ask questions for detail of encounters or uniques for a division
     28 K SDZ S SDZ(0)=0 K DIR S DIR(0)="Y",DIR("A")="Would you like to print a detailed list of activity for a division",DIR("B")="NO" W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDZ(0)=-1 Q
     29 S SDZ(0)=Y Q:'Y  W !!!,$C(7),"   WARNING: Selection high activity areas will result in lengthy output!",!
     30 K DIR S DIR(0)="S^U:UNIQUES;V:VISITS;E:ENCOUNTERS",DIR("A")="Select type of list" D ^DIR I $D(DTOUT)!$D(DUOUT) S SDZ(0)=-1 Q
     31 S SDZ(1)=Y G:Y'="E" ZDIV
     32DET1 K DIC S DIC="^SD(409.63,",DIC(0)="AEMQ",DIC("S")="I Y<4!(Y=8!(Y=12!(Y=14)))",DIC("A")="Select encounter status: " W ! D ^DIC I $D(DTOUT)!$D(DUOUT)!($G(Y)<1) S SDZ(0)=-1 Q
     33 S SDZ(2)=$P(Y,U) G:(SDZ(2)'=2)&(SDZ(2)'=8) ZDIV K DIR S DIR("A")="Select transmission status for "_$S(SDZ(2)=2:"CHECKED OUT",1:"INPATIENT APPOINTMENT")_" encounters"
     34 S DIR(0)="S^A:All transmission statuses;1:No transmission record;2:Not required, not transmitted;3:Rejected for transmission;4:Awaiting transmission;"
     35 S DIR(0)=DIR(0)_"5:Transmitted, no acknowledgment;6:Transmitted, rejected;7:Transmitted, error;8:Transmitted, accepted"
     36 W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDZ(0)=-1 Q  ;SD*5.3*339 add sub-zero
     37 S SDZ(3)=+Y
     38ZDIV ;Get division for detail
     39 I '$P($G(^DG(43,1,"GL")),U,2) S SDZ(4)=$P(^DG(40.8,$$PRIM^VASITE(),0),U) Q
     40 K DIC S DIC="^DG(40.8,",DIC("A")="Select Medical Center division for detail: ",DIC(0)="AEMQ" W ! D ^DIC I $D(DTOUT)!$D(DUOUT) S SDZ(0)=-1 Q
     41 I Y<1 W $C(7),"    Required for patient detail!" G ZDIV
     42 S SDZ(4)=$P(Y,U,2) Q
     43 ;
     44DPRT(SDS1,SDS2) ;Detail print
     45 ;Required input: SDS1,SDS2=subscript values
     46 K SDH S SDPAGE=1,SDH(1)="<*>  DETAILED LIST OF DIVISION "_$S(SDZ(1)="U":"UNIQUES",SDZ(1)="V":"VISITS",1:"ENCOUNTERS")_"  <*>",SDH(2)="For division: "_SDZ(4)
     47 I $G(SDZ(2)) S SDH(3)="Encounters with "_$P(^SD(409.63,SDZ(2),0),U)_" status"
     48 I "28"[$G(SDZ(2)) S SDH(4)="Transmission status: "_$P($T(TXS+SDZ(3)),";",2)
     49 D DHDR Q:SDOUT  I '$D(^TMP(SDS1,$J,SDS2,"DETAIL")) W !,"No records found in this category." Q
     50 S SDCT=0 D @SDZ(1) Q
     51 ;
     52U ;Print uniques
     53 S SDPNAM="" F  S SDPNAM=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM)) Q:SDPNAM=""!SDOUT  S DFN=0 F  S DFN=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN)) Q:'DFN!SDOUT  D U1
     54 Q:SDOUT  W !!,SDCT," uniques identified." Q
     55 ;
     56U1 S SDCT=SDCT+1,SDSSN=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,"")) D:$Y>(IOSL-4) DHDR Q:SDOUT  W !,$E(SDPNAM,1,18),?21,SDSSN Q
     57 ;
     58V ;Print visits
     59 S SDPNAM="" F  S SDPNAM=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM)) Q:SDPNAM=""!SDOUT  S DFN=0 F  S DFN=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN)) Q:'DFN!SDOUT  S SDSSN=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,"")) D V1
     60 Q:SDOUT  W !!,SDCT," visits identified." Q
     61 ;
     62V1 D:$Y>(IOSL-4) DHDR Q:SDOUT  W !,$E(SDPNAM,1,18),?21,SDSSN S (SDDT,SDI)=0 F  S SDDT=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,SDSSN,SDDT)) Q:'SDDT!SDOUT  D
     63 .D:$Y>(IOSL-3) DHDR Q:SDOUT  S Y=SDDT X ^DD("DD") W:SDI ! W ?32,Y S SDCT=SDCT+1,SDI=SDI+1
     64 .Q
     65 Q
     66 ;
     67E ;Print encounters
     68 S SDPNAM="" F  S SDPNAM=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM)) Q:SDPNAM=""!SDOUT  S DFN=0 F  S DFN=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN)) Q:'DFN!SDOUT  S SDSSN=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,"")) D E1
     69 Q:SDOUT  W !!,SDCT," encounters identified." Q
     70 ;
     71E1 D:$Y>(IOSL-4) DHDR Q:SDOUT  W !,$E(SDPNAM,1,18),?21,SDSSN
     72 S (SDDT,SDI)=0 F  S SDDT=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,SDSSN,SDDT)) Q:'SDDT!SDOUT  S SDOE=0 F  S SDOE=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,SDSSN,SDDT,SDOE)) Q:'SDOE!SDOUT  D E2
     73 Q
     74 ;
     75E2 D:$Y>(IOSL-3) DHDR Q:SDOUT  S SDHL=^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,SDSSN,SDDT,SDOE),SDHL=$P($G(^SC(+SDHL,0)),U),Y=SDDT X ^DD("DD") W:SDI ! W ?32,$P(Y,":",1,2),?50,SDHL S SDCT=SDCT+1,SDI=SDI+1 Q
     76 ;
     77DHDR I $E(IOST)="C" N DIR S DIR(0)="E" D ^DIR S SDOUT=Y'=1 Q:SDOUT
     78 D STOP^SCRPW8 Q:SDOUT
     79 W $$XY^SCRPW50(IOF,1,0),SDLINE S I=0 F  S I=$O(SDH(I)) Q:'I  W !?(80-$L(SDH(I))\2),SDH(I)
     80 W !,SDLINE,!,"For date range: ",SDDTPF," to ",SDDTPL,!,"Date printed: ",SDPNOW,?(74-$L(SDPAGE)),"Page: ",SDPAGE,!,SDLINE,! S SDPAGE=SDPAGE+1 Q
     81 ;
     82TXS ;All transmission statuses
     83 ;No transmission record
     84 ;Not required, not transmitted
     85 ;Rejected for transmission
     86 ;Awaiting transmission
     87 ;Transmitted, no acknowledgment
     88 ;Transmitted, rejected
     89 ;Transmitted, error
     90 ;Transmitted, accepted
     91 ;
     92PARM ;Prompt for report parameters
     93 D TITL^SCRPW50("Outpatient Encounter Workload Statistics")
     94 N %DT,DIR,DIC D SUBT^SCRPW50("*** Date Range Selection ***")
     95FDT W ! S %DT="AEPX",%DT("A")="Beginning date:  FIRST// ",%DT(0)=2961001 D ^%DT G:X=U!$D(DTOUT) EXIT^SCRPW8 I X="" S (Y,SDDTF)=2961001 X ^DD("DD") W "  ",Y,! S SDDTPF=Y G LDT
     96 G:Y<1 FDT S SDDTF=Y X ^DD("DD") S SDDTPF=Y W !
     97LDT S %DT("A")="Ending date:  LAST// " D ^%DT G:X=U!$D(DTOUT) EXIT^SCRPW8 I X="" S X1=DT,X2=-1 D C^%DTC S (Y,SDDTL)=X X ^DD("DD") W "  ",Y,! S SDDTPL=Y G ASK
     98 I Y<SDDTF W !!,$C(7),"Ending date must be after beginning date!",! G LDT
     99 G:Y<1 LDT S SDDTL=Y X ^DD("DD") S SDDTPL=Y,SDDTL=SDDTL_".999999"
     100ASK D SUBT^SCRPW50("*** Additional Detail Selection ***")
     101 W ! K DIR S DIR(0)="Y",DIR("A")="Break out workload by clinic group",DIR("B")="NO",DIR("?")="Specify if subtotals by encounter location CLINIC GROUP should be provided." D ^DIR G:$D(DTOUT)!$D(DUOUT) EXIT^SCRPW8 S SDCLGR=Y
     102 D DETAIL^SCRPW9 W ! G:SDZ(0)=-1 EXIT^SCRPW8
     103 K DIR S DIR(0)="Y",DIR("A")="List facility 'action required'/not accepted unique patients",DIR("B")="NO" D ^DIR G:$D(DTOUT)!$D(DUOUT) EXIT^SCRPW8 S SDUL=Y W !
     104QUE S ZTRTN="PST^SCRPW8",ZTDESC="Outpatient Encounter Workload" F SDI="SDCLGR","SDDTF","SDDTPF","SDDTL","SDDTPL","SDUL","SDDUL","SDZ(" S ZTSAVE(SDI)=""
     105 D EN^XUTMDEVQ(ZTRTN,ZTDESC,.ZTSAVE) G EXIT^SCRPW8

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDAL.m

    r613 r623  
    1 SDAL    ;ALB/GRR,MJK - APPOINTMENT LIST ; 29 Jun 99  04:11PM  ; Compiled August 20, 2007 14:24:59
    2         ;;5.3;Scheduling;**37,46,106,171,177,80,266,491**;Aug 13, 1993;Build 53
    3 EN      W ! S SDEND=1 D ASK2^SDDIV G:Y<0 END
    4         W ! S VAUTNI=1 D NCOUNT^SDAL0 I SDCONC=U G END
    5         W ! D NCLINIC^SDAL0 G:Y<0 END
    6 RD1     W ! N %DT K DIC("S") S %DT("A")="For date: ",%DT="AEX" D ^%DT
    7         I (X["^")!(Y<0) K %,VAUTD,VAUTC,X,Y Q
    8         S SDD=Y
    9         N DIR S DIR(0)="Y",DIR("B")="NO"
    10         S DIR("A")="Include Primary Care assignment information in the output"
    11         W ! D ^DIR I $D(DTOUT)!$D(DUOUT) K SDD,VAUTC,VAUTD,X,Y Q
    12         W ! S SDPCMM=Y
    13 N       K SDX,SDX1 R !,"Number of copies: 1// ",M:DTIME S:M="" M=1
    14         I M["^" K M,SDD,VAUTC,VAUTD,X,Y Q
    15         I (M'?.N)!((M'>0)!($L(M)>3)) W !,"ENTER A WHOLE NUMBER TO SELECT THE # OF COPIES OF THE APPOINTMENT LIST THAT ARE NEEDED- (1-999)" G N
    16         S SDCOPY=M
    17         ; -- specify device
    18         W ! N %ZIS K IO("Q") S %ZIS="QMP" D ^%ZIS G END:POP
    19         S SDBC=$$BARQ(+IOST(0),IOM) I SDBC="^" G END
    20         I $D(IO("Q")) D QUE W:$D(ZTSK) "   (Task#: ",ZTSK,")" G END
    21         ;
    22 START   U IO N CNT,SDCLAR,SDCOUNT S (SDCOUNT,CNT)=0
    23         ;SET UP A TEMP ARRAY -SDCLAR- WITH CLASSIFICATION ABBREVIATIONS
    24         F  S CNT=$O(^SD(409.41,CNT)) Q:CNT'>0  D
    25         .S SDCLAR(CNT)=$P(^SD(409.41,CNT,0),U,7)
    26         S:'$D(DTIME) DTIME=300 I '$D(DT) D DT^SDUTL
    27         S SDASH="",$P(SDASH,"_",IOM+1)="" S SDBC=+$G(SDBC),SDCOPY=$S($D(SDCOPY):+SDCOPY,$D(M):+M,1:1)
    28         D NOW^%DTC S Y=% X ^DD("DD") S SDPNOW=$P(Y,":",1,2)
    29         I SDBC S SDBC=$S(IOM<120:0,1:$$BARC^SDAMU(+IOST(0),.SDBCON,.SDBCOFF))
    30         S (SDEND,SD1,PCNT)=0,Y=DT D D^DIQ S SDNT=Y,Y=SDD,X=Y D D^DIQ S SDPD=Y D DW^%DTC S SDPD=X_" "_SDPD
    31         ;if user has selected 'all' clinics, populate VAUTC with all uncancelled TYPE=C clinics from ^SC
    32         I VAUTC=1 S SDIEN=0 F  S SDIEN=$O(^SC(SDIEN)) Q:+SDIEN=0  D
    33         . I $P(^SC(SDIEN,0),"^",3)="C",$G(^SC(SDIEN,"ST",SDD,1))'["CANCELLED" D
    34         .. S SDNAME=$P(^SC(SDIEN,0),"^",1) I $G(SDNAME)]"" S VAUTC(SDNAME)=SDIEN
    35         ;-------------CALL TO SDAPI^SDAMA301 TO RETRIEVE APPT DATA------------------
    36         K ^TMP($J,"SDAMA301") N SDARRAY,SDIEN,SDNAME,SDERR,SDCL,SDDFN,SDDT,SDRESULT
    37         S SDARRAY(1)=SDD_";"_SDD,SDARRAY(3)="I;R;NT",SDARRAY("FLDS")="4;6;7;8;10;19;20;21"
    38         ;if user has selected clinics, build clinic filter list
    39         I VAUTC'=1 D  I $L(SDARRAY(2)) S SDARRAY(2)=$E(SDARRAY(2),1,$L(SDARRAY(2))-1) ;remove last ';' from end
    40         . S SD="" F  S SD=$O(VAUTC(SD)) Q:SD']""  S SC=$G(VAUTC(SD)) I $G(SC)]"" S SDARRAY(2)=$G(SDARRAY(2))_SC_";"
    41         ;call SDAPI to retrieve appointment data
    42         S SDRESULT=$$SDAPI^SDAMA301(.SDARRAY)
    43         ;I SDRESULT<0 S SDERR=$$SDAPIERR^SDAMUTDT() I $L(SDERR) S SC=0 D HED W !!,SDERR,! I $E(IOST,1,2)="C-" D OUT^SDUTL
    44         ;if error returned from SDAPI, display on report and quit
    45         I SDRESULT<0 S SDERR=$$SDAPIERR^SDAMUTDT() I $L(SDERR) S SC=0 S SDPAGE=1 D HED W !!,SDERR,! D:$E(IOST,1,2)="C-" OUT^SDUTL D EXIT Q
    46         ;if appts returned from SDAPI, sort output by clinic, appt d/t, patient
    47         I SDRESULT>0 D
    48         . S SDCL=0 F  S SDCL=$O(^TMP($J,"SDAMA301",SDCL)) Q:'SDCL  D
    49         .. S SDDFN=0 F  S SDDFN=$O(^TMP($J,"SDAMA301",SDCL,SDDFN)) Q:'SDDFN  D
    50         ... S SDDT=0 F  S SDDT=$O(^TMP($J,"SDAMA301",SDCL,SDDFN,SDDT)) Q:'SDDT  D
    51         .... M ^TMP($J,"SDAMA301","S",SDCL,SDDT,SDDFN)=^TMP($J,"SDAMA301",SDCL,SDDFN,SDDT)
    52         ;---------------------------------------------------------------------------
    53 LOOPA   ;S SD=0 F  S SD=$S(VAUTC:$O(^SC("B",SD)),1:$O(VAUTC(SD))) Q:SD']""!SDEND  D CLIN
    54         ;if no error returned from SDAPI, start looping through clinics in VAUTC (sorted by name)
    55         I SDRESULT'<0 S SD=0 F  S SD=$O(VAUTC(SD)) Q:SD']""!SDEND  D CLIN
    56         G:SDEND END
    57 OVER    ;S PCNT=PCNT+1 I PCNT<SDCOPY,SDCOUNT S VAUTC=0 G LOOPA
    58         S PCNT=PCNT+1 I PCNT<SDCOPY,SDCOUNT G LOOPA
    59 END     I $G(SDCOUNT)="" G EXIT
    60         ;I SDCOUNT=0 S SDPCT="No activity found for this date!" D HED W !!?$L(SDPCT)\2,SDPCT,!
    61         I SDCOUNT=0 S SDPCT="No activity found for this date!" S SDPAGE=1,SC=0 D HED W !!?$L(SDPCT)\2,SDPCT,!
    62         I $E(IOST,1,2)="C-" D:'$G(SDEND)&$G(SDCOUNT) OUT^SDUTL W @IOF
    63 EXIT    K %,%H,%H,A,ALL,DFN,DIC,I,INC,K,M,PCNT,POP,PT,SC,SD,SD1,SDCC,SDCONC,SDCP,SDD,SDEM1,SDDIF,SDDIF1,SDEA,SDEC,SDEDT,SDEM,SDEND,SDFL,SDFS,SDIN,SDNT
    64         K DIRUT,SDCOPY,SDPAGE,SDPCT,SDPNOW,SDPT0,SDOI,SDPD,SDREV,SDT,SDX,SDXX,SDZ,VADAT,VADATE,VAUTC,VAUTNI,VAUTSTR,VAUTVB,VAUTD,VAQK,X,Y,Y1,Y2,Z
    65         K SDBC,SDBCON,SDBCOFF,SDASH,SDPCMM,^TMP($J,"SDAMA301")
    66         D CLOSE^DGUTQ Q
    67         ;
    68 CLIN    ;S (SDFL,SC)=0 F  S SC=$O(^SC("B",SD,SC)) Q:SC'>0!SDEND  I $D(^SC(SC,0)),$P(^(0),"^",3)="C" I $S(VAUTC:1,'$D(VAUTC(SD)):0,VAUTC(SD)=SC:1,1:0) D LOOP^SDAL0
    69         ;process each clinic IEN from VAUTC array
    70         S (SDFL,SC)=0 S SC=$G(VAUTC(SD)) I $G(SC)>0,$D(^SC(SC,0)) D LOOP^SDAL0
    71         Q
    72         ;
    73 BARQ(TTYPE,MARGIN)      ;
    74         N ON,OFF,Y
    75         I MARGIN<120 S Y=0 G BARCQ
    76         I '$$BARC^SDAMU(.TTYPE,.ON,.OFF) S Y=0 G BARCQ
    77         S DIR(0)="Y",DIR("B")="NO",DIR("A")="SHOULD BARCODES BE PRINTED ON LIST(S)"
    78         D ^DIR K DIR S:$D(DIRUT) Y="^"
    79 BARCQ   Q Y
    80         ;
    81 QUE     ;Queue output
    82         N ZTDESC,ZTSAVE,ZTRTN
    83         K ZTSK,IO("Q")
    84         S ZTDESC="Appointment Lists",ZTRTN="START^SDAL"
    85         F X="VAUTD(","VAUTC(","SDCOPY","SDD","SDBC","VAUTD","VAUTC","SDCONC","SDPCMM" S ZTSAVE(X)=""
    86         D ^%ZTLOAD
    87         Q
    88         ;
    89 STOP    ;Check for stop task request
    90         S:$D(ZTQUEUED) (SDEND,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q
    91         ;
    92 HED     ;Print report header
    93         I SD1,$E(IOST)="C" D OUT^SDUTL Q:SDEND
    94         D STOP Q:SDEND
    95         S SDCOUNT=SDCOUNT+1,SD1=1
    96         W:SDCOUNT>1!($E(IOST)="C") $$XY^SCRPW50(IOF,1,0) W:$X $$XY^SCRPW50("",0,0)
    97         W:SC "Appointments for ",$P(^SC(SC,0),"^",1)," clinic on ",SDPD
    98         W:'SC "Appointments for ",SDPD
    99         W !,"Date printed: ",SDPNOW,?(IOM-6-$L(SDPAGE)),"Page: ",SDPAGE,!
    100         W !," Appt.",?11,"Patient Name",?44,"SSN",?53,"Lab",?62,"X-Ray",?73,"EKG"
    101         ;W !," Time",?53,"Time",?62,"Time",?73,"Time",!,?15,"Other Information",?40,"Ward Location",!,?41,"Room-Bed"
    102         W !," Time",?53,"Time",?62,"Time",?73,"Time",!,?15,"Other Information",?40,"Ward Location",!,?41,"Room-Bed"
    103         W !,SDASH S SDPAGE=SDPAGE+1
    104         D:SDBC PAINT(SC,SDD)
    105         Q
    106         ;
    107 PAINT(CLINIC,DATE)      ; -- paint header barcodes
    108         ; input:  CLINIC := clinic ifn
    109         ;           DATE := appt date only
    110         ;
    111         W !?10,"Date",?45,"Clinic#",?85,"No",?110,"Yes",!
    112         D BARC(10,$E(DATE,4,7)_$E(DATE,2,3))
    113         D BARC(45,"%"_CLINIC_"$")
    114         D BARC(85,"N"),BARC(110,"Y")
    115         W !!!!,SDASH
    116         Q
    117         ;
    118 BARC(TAB,X)     ; --print barcode
    119         ; input: TAB := tab position
    120         ;          X := string to print
    121         ;
    122         W *13,?TAB W @SDBCON,X,@SDBCOFF
    123         Q
    124         ;
     1SDAL ;ALB/GRR,MJK - APPOINTMENT LIST ; 29 Jun 99  04:11PM
     2 ;;5.3;Scheduling;**37,46,106,171,177,80,266**;Aug 13, 1993
     3EN W ! S SDEND=1 D ASK2^SDDIV G:Y<0 END
     4 W ! S VAUTNI=1 D NCOUNT^SDAL0 I SDCONC=U G END
     5 W ! D NCLINIC^SDAL0 G:Y<0 END
     6RD1 W ! N %DT K DIC("S") S %DT("A")="For date: ",%DT="AEXF" D ^%DT
     7 I (X["^")!(Y<0) K %,VAUTD,VAUTC,X,Y Q
     8 S SDD=Y
     9 N DIR S DIR(0)="Y",DIR("B")="NO"
     10 S DIR("A")="Include Primary Care assignment information in the output"
     11 W ! D ^DIR I $D(DTOUT)!$D(DUOUT) K SDD,VAUTC,VAUTD,X,Y Q
     12 W ! S SDPCMM=Y
     13N K SDX,SDX1 R !,"Number of copies: 1// ",M:DTIME S:M="" M=1
     14 I M["^" K M,SDD,VAUTC,VAUTD,X,Y Q
     15 I (M'?.N)!((M'>0)!($L(M)>3)) W !,"ENTER A WHOLE NUMBER TO SELECT THE # OF COPIES OF THE APPOINTMENT LIST THAT ARE NEEDED- (1-999)" G N
     16 S SDCOPY=M
     17 ; -- specify device
     18 W ! N %ZIS K IO("Q") S %ZIS="QMP" D ^%ZIS G END:POP
     19 S SDBC=$$BARQ(+IOST(0),IOM) I SDBC="^" G END
     20 I $D(IO("Q")) D QUE W:$D(ZTSK) "   (Task#: ",ZTSK,")" G END
     21 ;
     22START U IO N CNT,SDCLAR,SDCOUNT S (SDCOUNT,CNT)=0
     23 ;SET UP A TEMP ARRAY -SDCLAR- WITH CLASSIFICATION ABBREVIATIONS
     24 F  S CNT=$O(^SD(409.41,CNT)) Q:CNT'>0  D
     25 .S SDCLAR(CNT)=$P(^SD(409.41,CNT,0),U,7)
     26 S:'$D(DTIME) DTIME=300 I '$D(DT) D DT^SDUTL
     27 S SDASH="",$P(SDASH,"_",IOM+1)="" S SDBC=+$G(SDBC),SDCOPY=$S($D(SDCOPY):+SDCOPY,$D(M):+M,1:1)
     28 D NOW^%DTC S Y=% X ^DD("DD") S SDPNOW=$P(Y,":",1,2)
     29 I SDBC S SDBC=$S(IOM<120:0,1:$$BARC^SDAMU(+IOST(0),.SDBCON,.SDBCOFF))
     30 S (SDEND,SD1,PCNT)=0,Y=DT D D^DIQ S SDNT=Y,Y=SDD,X=Y D D^DIQ S SDPD=Y D DW^%DTC S SDPD=X_" "_SDPD
     31 ;if user has selected 'all' clinics, populate VAUTC with all uncancelled TYPE=C clinics from ^SC
     32 I VAUTC=1 S SDIEN=0 F  S SDIEN=$O(^SC(SDIEN)) Q:+SDIEN=0  D
     33 . I $P(^SC(SDIEN,0),"^",3)="C",$G(^SC(SDIEN,"ST",SDD,1))'["CANCELLED" D
     34 .. S SDNAME=$P(^SC(SDIEN,0),"^",1) I $G(SDNAME)]"" S VAUTC(SDNAME)=SDIEN
     35 ;-------------CALL TO SDAPI^SDAMA301 TO RETRIEVE APPT DATA------------------
     36 K ^TMP($J,"SDAMA301") N SDARRAY,SDIEN,SDNAME,SDERR,SDCL,SDDFN,SDDT,SDRESULT
     37 S SDARRAY(1)=SDD_";"_SDD,SDARRAY(3)="I;R;NT",SDARRAY("FLDS")="4;6;7;8;10;19;20;21"
     38 ;if user has selected clinics, build clinic filter list
     39 I VAUTC'=1 D  I $L(SDARRAY(2)) S SDARRAY(2)=$E(SDARRAY(2),1,$L(SDARRAY(2))-1) ;remove last ';' from end
     40 . S SD="" F  S SD=$O(VAUTC(SD)) Q:SD']""  S SC=$G(VAUTC(SD)) I $G(SC)]"" S SDARRAY(2)=$G(SDARRAY(2))_SC_";"
     41 ;call SDAPI to retrieve appointment data
     42 S SDRESULT=$$SDAPI^SDAMA301(.SDARRAY)
     43 ;I SDRESULT<0 S SDERR=$$SDAPIERR^SDAMUTDT() I $L(SDERR) S SC=0 D HED W !!,SDERR,! I $E(IOST,1,2)="C-" D OUT^SDUTL
     44 ;if error returned from SDAPI, display on report and quit
     45 I SDRESULT<0 S SDERR=$$SDAPIERR^SDAMUTDT() I $L(SDERR) S SC=0 S SDPAGE=1 D HED W !!,SDERR,! D:$E(IOST,1,2)="C-" OUT^SDUTL D EXIT Q
     46 ;if appts returned from SDAPI, sort output by clinic, appt d/t, patient
     47 I SDRESULT>0 D
     48 . S SDCL=0 F  S SDCL=$O(^TMP($J,"SDAMA301",SDCL)) Q:'SDCL  D
     49 .. S SDDFN=0 F  S SDDFN=$O(^TMP($J,"SDAMA301",SDCL,SDDFN)) Q:'SDDFN  D
     50 ... S SDDT=0 F  S SDDT=$O(^TMP($J,"SDAMA301",SDCL,SDDFN,SDDT)) Q:'SDDT  D
     51 .... M ^TMP($J,"SDAMA301","S",SDCL,SDDT,SDDFN)=^TMP($J,"SDAMA301",SDCL,SDDFN,SDDT)
     52 ;---------------------------------------------------------------------------
     53LOOPA ;S SD=0 F  S SD=$S(VAUTC:$O(^SC("B",SD)),1:$O(VAUTC(SD))) Q:SD']""!SDEND  D CLIN
     54 ;if no error returned from SDAPI, start looping through clinics in VAUTC (sorted by name)
     55 I SDRESULT'<0 S SD=0 F  S SD=$O(VAUTC(SD)) Q:SD']""!SDEND  D CLIN
     56 G:SDEND END
     57OVER ;S PCNT=PCNT+1 I PCNT<SDCOPY,SDCOUNT S VAUTC=0 G LOOPA
     58 S PCNT=PCNT+1 I PCNT<SDCOPY,SDCOUNT G LOOPA
     59END I $G(SDCOUNT)="" G EXIT
     60 ;I SDCOUNT=0 S SDPCT="No activity found for this date!" D HED W !!?$L(SDPCT)\2,SDPCT,!
     61 I SDCOUNT=0 S SDPCT="No activity found for this date!" S SDPAGE=1,SC=0 D HED W !!?$L(SDPCT)\2,SDPCT,!
     62 I $E(IOST,1,2)="C-" D:'$G(SDEND)&$G(SDCOUNT) OUT^SDUTL W @IOF
     63EXIT K %,%H,%H,A,ALL,DFN,DIC,I,INC,K,M,PCNT,POP,PT,SC,SD,SD1,SDCC,SDCONC,SDCP,SDD,SDEM1,SDDIF,SDDIF1,SDEA,SDEC,SDEDT,SDEM,SDEND,SDFL,SDFS,SDIN,SDNT
     64 K DIRUT,SDCOPY,SDPAGE,SDPCT,SDPNOW,SDPT0,SDOI,SDPD,SDREV,SDT,SDX,SDXX,SDZ,VADAT,VADATE,VAUTC,VAUTNI,VAUTSTR,VAUTVB,VAUTD,VAQK,X,Y,Y1,Y2,Z
     65 K SDBC,SDBCON,SDBCOFF,SDASH,SDPCMM,^TMP($J,"SDAMA301")
     66 D CLOSE^DGUTQ Q
     67 ;
     68CLIN ;S (SDFL,SC)=0 F  S SC=$O(^SC("B",SD,SC)) Q:SC'>0!SDEND  I $D(^SC(SC,0)),$P(^(0),"^",3)="C" I $S(VAUTC:1,'$D(VAUTC(SD)):0,VAUTC(SD)=SC:1,1:0) D LOOP^SDAL0
     69 ;process each clinic IEN from VAUTC array
     70 S (SDFL,SC)=0 S SC=$G(VAUTC(SD)) I $G(SC)>0,$D(^SC(SC,0)) D LOOP^SDAL0
     71 Q
     72 ;
     73BARQ(TTYPE,MARGIN) ;
     74 N ON,OFF,Y
     75 I MARGIN<120 S Y=0 G BARCQ
     76 I '$$BARC^SDAMU(.TTYPE,.ON,.OFF) S Y=0 G BARCQ
     77 S DIR(0)="Y",DIR("B")="NO",DIR("A")="SHOULD BARCODES BE PRINTED ON LIST(S)"
     78 D ^DIR K DIR S:$D(DIRUT) Y="^"
     79BARCQ Q Y
     80 ;
     81QUE ;Queue output
     82 N ZTDESC,ZTSAVE,ZTRTN
     83 K ZTSK,IO("Q")
     84 S ZTDESC="Appointment Lists",ZTRTN="START^SDAL"
     85 F X="VAUTD(","VAUTC(","SDCOPY","SDD","SDBC","VAUTD","VAUTC","SDCONC","SDPCMM" S ZTSAVE(X)=""
     86 D ^%ZTLOAD
     87 Q
     88 ;
     89STOP ;Check for stop task request
     90 S:$D(ZTQUEUED) (SDEND,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q
     91 ;
     92HED ;Print report header
     93 I SD1,$E(IOST)="C" D OUT^SDUTL Q:SDEND
     94 D STOP Q:SDEND
     95 S SDCOUNT=SDCOUNT+1,SD1=1
     96 W:SDCOUNT>1!($E(IOST)="C") $$XY^SCRPW50(IOF,1,0) W:$X $$XY^SCRPW50("",0,0)
     97 W:SC "Appointments for ",$P(^SC(SC,0),"^",1)," clinic on ",SDPD
     98 W:'SC "Appointments for ",SDPD
     99 W !,"Date printed: ",SDPNOW,?(IOM-6-$L(SDPAGE)),"Page: ",SDPAGE,!
     100 W !," Appt.",?11,"Patient Name",?44,"SSN",?53,"Lab",?62,"X-Ray",?73,"EKG"
     101 ;W !," Time",?53,"Time",?62,"Time",?73,"Time",!,?15,"Other Information",?40,"Ward Location",!,?41,"Room-Bed"
     102 W !," Time",?53,"Time",?62,"Time",?73,"Time",!,?15,"Other Information",?40,"Ward Location",!,?41,"Room-Bed"
     103 W !,SDASH S SDPAGE=SDPAGE+1
     104 D:SDBC PAINT(SC,SDD)
     105 Q
     106 ;
     107PAINT(CLINIC,DATE) ; -- paint header barcodes
     108 ; input:  CLINIC := clinic ifn
     109 ;           DATE := appt date only
     110 ;
     111 W !?10,"Date",?45,"Clinic#",?85,"No",?110,"Yes",!
     112 D BARC(10,$E(DATE,4,7)_$E(DATE,2,3))
     113 D BARC(45,"%"_CLINIC_"$")
     114 D BARC(85,"N"),BARC(110,"Y")
     115 W !!!!,SDASH
     116 Q
     117 ;
     118BARC(TAB,X) ; --print barcode
     119 ; input: TAB := tab position
     120 ;          X := string to print
     121 ;
     122 W *13,?TAB W @SDBCON,X,@SDBCOFF
     123 Q
     124 ;

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDAM10.m

    r613 r623  
    1 SDAM10  ;MJK/ALB - Appt Mgt (Patient cont.); 3/18/05 3:51pm  ; Compiled March 31, 2008 16:38:47
    2         ;;5.3;Scheduling;**189,258,403,478,491**;Aug 13, 1993;Build 53
    3         ;
    4 HDR     ; -- list screen header
    5         ;   input:       SDFN := ifn of pat
    6         ;  output:  VALMHDR() := hdr array
    7         ;
    8         N VAERR,VA,X
    9         S DFN=SDFN D PID^VADPT
    10         S VALMHDR(1)=$E($P("Patient: "_$G(^DPT(SDFN,0)),U),1,46)_" ("_VA("BID")_")"  ;for proper display of patient name for SD*5.3*189
    11         S X=$P($$FMT^SDUTL2(SDFN),U,2),X=$S(X["GMT":X,X]"":"MT: "_X,1:"")
    12         S VALMHDR(1)=$$SETSTR^VALM1(X,VALMHDR(1),47,15)  ;repositioned header to display clinic or patient name properly for SD*5.3*189
    13         S X=$S($D(^DPT(SDFN,.1)):"Ward: "_^(.1),1:"Outpatient")
    14         S VALMHDR(1)=$$SETSTR^VALM1(X,VALMHDR(1),81-$L(X),$L(X))
    15         Q
    16         ;
    17 PAT     ; -- change pat
    18         K TMP ;SD/478
    19         D FULL^VALM1 S VALMBCK="R"
    20         K X I $D(XQORNOD(0)) S X=$P($P(XQORNOD(0),U,4),"=",2)
    21         I $D(X),X="" R !!,"Select Patient: ",X:DTIME
    22         D RT^SDAMEX S DIC="^DPT(",DIC(0)="EMQ" D ^DIC K DIC G PAT:X["?"
    23 PAT1    S %=1 I Y>0 W !,"   ...OK" D YN^DICN I %=0 W "   Answer with 'Yes' or 'No'" G PAT1
    24         I %'=1 S Y=-1
    25         I Y<0 D  G PATQ
    26         .I $G(DFN)>0,SDAMTYP="P" S VALMSG=$C(7)_"Patient has not been changed."
    27         .I $G(DFN)'>0,SDAMTYP="P" S VALMSG=$C(7)_"Patient has not been selected."
    28         .I SDAMTYP="C" S VALMSG=$C(7)_"View of clinic remains in affect."
    29         .W !!,$G(VALMSG) H 1
    30         I SDAMTYP'="P" D CHGCAP^VALM("NAME","Clinic") S SDAMTYP="P"
    31         S (DFN,SDFN)=+Y K SDCLN,VADM D DEM^VADPT D BLD^SDAM1 ;SD/491
    32 PATQ    Q
    33         ;
    34 INIT    ; -- init bld vars
    35         K VALMHDR,SDDA,^TMP("SDAMIDX",$J)
    36         D CLEAN^VALM10
    37         S VALMBG=1,(VALMCNT,SDACNT)=0,BL="",$P(BL," ",30)="",SDMAX=100
    38         S SDAMDD=$P(^DD(2.98,3,0),U,3)
    39         ; -- format vars     |- column -| |- width -|
    40         S X=VALMDDF("APPT#"),AC=$P(X,U,2),AW=$P(X,U,3) ; A for appt
    41         S X=VALMDDF("DATE"),XC=$P(X,U,2),XW=$P(X,U,3) ;  X for date
    42         S X=VALMDDF("NAME"),NC=$P(X,U,2),NW=$P(X,U,3) ;  N for name
    43         S X=VALMDDF("STAT"),SC=$P(X,U,2),SW=$P(X,U,3) ;  S for status
    44         S X=VALMDDF("TIME"),TC=$P(X,U,2),TW=$P(X,U,3) ;  T for time
    45         S (CC,CW)="",X=$G(VALMDDF("CONSULT")) I X'="" S CC=$P(X,U,2),CW=$P(X,U,3) ;  C for Consult ;SD/478
    46         Q
    47         ;
    48 LARGE   ; -- too large note
    49         W !!?5,*7,"Note: Ending Date was changed to '",$$FDATE^VALM1(SDEND),"' because"
    50         W !?11,"too many appointments met date range criteria." D PAUSE^VALM1
    51         Q
    52         ;
    53 NUL     ; -- set nul message
    54         I '$O(^TMP("SDAM",$J,0)) D SET^SDAM1(" "),SET^SDAM1("    No appointments meet criteria.")
    55         Q
    56         ;
     1SDAM10 ;MJK/ALB - Appt Mgt (Patient cont.); 3/18/05 3:51pm
     2 ;;5.3;Scheduling;**189,258,403,478**;Aug 13, 1993
     3 ;
     4HDR ; -- list screen header
     5 ;   input:       SDFN := ifn of pat
     6 ;  output:  VALMHDR() := hdr array
     7 ;
     8 N VAERR,VA,X
     9 S DFN=SDFN D PID^VADPT
     10 S VALMHDR(1)=$E($P("Patient: "_$G(^DPT(SDFN,0)),U),1,46)_" ("_VA("BID")_")"  ;for proper display of patient name for SD*5.3*189
     11 S X=$P($$FMT^SDUTL2(SDFN),U,2),X=$S(X["GMT":X,X]"":"MT: "_X,1:"")
     12 S VALMHDR(1)=$$SETSTR^VALM1(X,VALMHDR(1),47,15)  ;repositioned header to display clinic or patient name properly for SD*5.3*189
     13 S X=$S($D(^DPT(SDFN,.1)):"Ward: "_^(.1),1:"Outpatient")
     14 S VALMHDR(1)=$$SETSTR^VALM1(X,VALMHDR(1),81-$L(X),$L(X))
     15 Q
     16 ;
     17PAT ; -- change pat
     18 K TMP ;SD/478
     19 D FULL^VALM1 S VALMBCK="R"
     20 K X I $D(XQORNOD(0)) S X=$P($P(XQORNOD(0),U,4),"=",2)
     21 I $D(X),X="" R !!,"Select Patient: ",X:DTIME
     22 D RT^SDAMEX S DIC="^DPT(",DIC(0)="EMQ" D ^DIC K DIC G PAT:X["?"
     23PAT1 S %=1 W !,"   ...OK" D YN^DICN I %=0 W "   Answer with 'Yes' or 'No'" G PAT1
     24 I %'=1 S Y=-1
     25 I Y<0 D  G PATQ
     26 .I SDAMTYP="P" S VALMSG=$C(7)_"Patient has not been changed."
     27 .I SDAMTYP="C" S VALMSG=$C(7)_"View of clinic remains in affect."
     28 I SDAMTYP'="P" D CHGCAP^VALM("NAME","Clinic") S SDAMTYP="P"
     29 S SDFN=+Y K SDCLN D BLD^SDAM1
     30PATQ Q
     31 ;
     32INIT ; -- init bld vars
     33 K VALMHDR,SDDA,^TMP("SDAMIDX",$J)
     34 D CLEAN^VALM10
     35 S VALMBG=1,(VALMCNT,SDACNT)=0,BL="",$P(BL," ",30)="",SDMAX=100
     36 S SDAMDD=$P(^DD(2.98,3,0),U,3)
     37 ; -- format vars     |- column -| |- width -|
     38 S X=VALMDDF("APPT#"),AC=$P(X,U,2),AW=$P(X,U,3) ; A for appt
     39 S X=VALMDDF("DATE"),XC=$P(X,U,2),XW=$P(X,U,3) ;  X for date
     40 S X=VALMDDF("NAME"),NC=$P(X,U,2),NW=$P(X,U,3) ;  N for name
     41 S X=VALMDDF("STAT"),SC=$P(X,U,2),SW=$P(X,U,3) ;  S for status
     42 S X=VALMDDF("TIME"),TC=$P(X,U,2),TW=$P(X,U,3) ;  T for time
     43 S (CC,CW)="",X=$G(VALMDDF("CONSULT")) I X'="" S CC=$P(X,U,2),CW=$P(X,U,3) ;  C for Consult ;SD/478
     44 Q
     45 ;
     46LARGE ; -- too large note
     47 W !!?5,*7,"Note: Ending Date was changed to '",$$FDATE^VALM1(SDEND),"' because"
     48 W !?11,"too many appointments met date range criteria." D PAUSE^VALM1
     49 Q
     50 ;
     51NUL ; -- set nul message
     52 I '$O(^TMP("SDAM",$J,0)) D SET^SDAM1(" "),SET^SDAM1("    No appointments meet criteria.")
     53 Q
     54 ;

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDAMODO3.m

    r613 r623  
    1 SDAMODO3        ;ALB/SCK - PROVIDER DIAGNOSTICS REPORT OUTPUT ; 05 Oct 98  8:44 PM
    2         ;;5.3;Scheduling;**11,25,46,49,159,529**;Aug 13, 1993;Build 3
    3         Q
    4 REPORT  ;
    5         I '$D(^TMP("SDRPT",$J)) D NOREP G EXIT
    6 START   ;
    7         N SDIV,OEN,SDPRX,SUB1,SUB2,OEN,SDATA,SDX,SPRV,SDCHECK
    8         S (SDIV,SDFIN,SDVC,SUBX,SUB1,SUB2)="",(PAGE,QFLAG,SUBCNT)=0
    9         W:$E(IOST,1,2)="C-" @IOF
    10         F  S SDIV=$O(^TMP("SDRPT",$J,SDIV)) Q:SDIV=""  D  Q:SDFIN
    11         . I SDIV'=SDVC S SUBX=$$SUBCNT(SUB1,SUBX),SDFIN='$$HDR(SDIV) Q:SDFIN  S SDVC=SDIV
    12         . S SUB1="" F  S SUB1=$O(^TMP("SDRPT",$J,SDIV,SUB1)) Q:SUB1=""  D  Q:SDFIN
    13         .. I SUBX'=SUB1 S SUBX=$$SUBCNT(SUB1,SUBX)
    14         .. I SORT1=4!(SORT1=5) I SUBX]"",SUBX'=SUB1 S SDFIN='$$HDR(SDIV)
    15         .. S SUB2="" F  S SUB2=$O(^TMP("SDRPT",$J,SDIV,SUB1,SUB2)) Q:SUB2=""  D  Q:SDFIN
    16         ... S OEN=0 F  S OEN=$O(^TMP("SDRPT",$J,SDIV,SUB1,SUB2,OEN)) Q:'OEN  S SUBCNT=SUBCNT+1,SDCHECK="" D  Q:SDFIN
    17         .... S I=0 F  S I=$O(^TMP("SDRPT",$J,SDIV,SUB1,SUB2,OEN,I)) Q:'I  S SDFIN='$$PRNT(I) Q:SDFIN
    18         S SUBX=$$SUBCNT(SUB1,SUBX)
    19 EXIT    ;
    20         K QFLAG,PAGE,SDFIN,SDVC,SDONE,XX,^TMP("SDRPT",$J),SUBCNT,SUBX
    21         Q
    22         ;
    23 SUBCNT(SB1,SB1P)        ;
    24         I SB1P']""!(SUBCNT'>0) G SUBCNTQ
    25         W !,SUBCNT," ",$S(SORT2=1!(SORT2=2):"Primary "_$P($T(SORT+SORT2^SDAMODO1),";;",2),1:$P($T(SORT+SORT2^SDAMODO1),";;",2))," entries for ",$S(SORT1=1!(SORT1=3):$P(SB1P,"^"),SORT1=5:$P($G(^DIC(40.7,SB1P,0)),U),1:SB1P),!!
    26         S SUBCNT=0
    27 SUBCNTQ Q (SB1)
    28         ;
    29 PRNT(I) ;
    30         N Y,SDATA,SPRV,SDX,XX,SCODE,SDDX1,SDPRX,SDSID
    31         S SDATA=(^TMP("SDRPT",$J,SDIV,SUB1,SUB2,OEN,I,0))
    32         S XX="" F  S XX=$O(^TMP("SDRPT",$J,SDIV,SUB1,SUB2,OEN,I,"PRV",XX)) Q:'XX  S SPRV(XX)=""
    33         S XX="" F  S XX=$O(^TMP("SDRPT",$J,SDIV,SUB1,SUB2,OEN,I,"DX",XX)) Q:XX=""  S SDX(XX)=""
    34         I SORT1=1,'$$SELPRV(SUB1) S Y=1 G PRNTQ
    35         I SORT1=2,'$$SELDX(SUB1) S Y=1 G PRNTQ
    36         I $Y+5>IOSL  S Y='$$HDR(SDIV) G:Y PRNTQ
    37 LINE1   ;
    38         S SDSID=$P($G(SDATA),U,2)
    39         W !,$P(^DPT($P($G(SDATA),U),0),U)_" "_$P(SDSID,"-",3)
    40         S:SDCHECK="" SDCHECK=SDSID I SDSID'=SDCHECK S SUBCNT=SUBCNT+1
    41         W ?32,$P($$FMTE^XLFDT(OEN,1),":",1,2) ; modified to drop seconds
    42         W ?55,$E($P(SDATA,U,3),1,25)
    43         W ?90,$S(+$P(SDATA,U,5)>0:$P(^VA(200,+$P(SDATA,U,5),0),U),1:$P(SDATA,U,5))
    44         W ?117,$P(SDATA,U,6)
    45 LINE2   ;
    46         S SCODE=$P(SDATA,U,4)
    47         W !?56,$P($G(^DIC(40.7,+SCODE,0)),U,2),"/",$P($G(^DIC(40.7,+SCODE,0)),U)
    48         S SDPRX="",SDPRX=$O(SPRV(SDPRX)) I $D(SDPRX),SORT1'=1 W ?90,$S(+SDPRX>0:$P(^VA(200,SDPRX,0),U),1:"")
    49         S SDDX1="",SDDX1=$O(SDX(SDDX1)) I $D(SDDX1),SORT1'=2 W ?117,SDDX1
    50         S SDONE=0
    51         F XX=1:1 D  Q:SDONE
    52         . I SDDX1'="" S SDDX1=$O(SDX(SDDX1))
    53         . I SDPRX'="" S SDPRX=$O(SPRV(SDPRX))
    54         . I SDPRX']""&(SDDX1']"") S SDONE=1 Q
    55         . I $Y+5>IOSL S SDONE='$$HDR(SDIV) Q:SDONE
    56         . W !
    57         . I $D(SDPRX),SORT1'=1 W ?90,$S(+SDPRX>0:$P(^VA(200,SDPRX,0),U),1:"")
    58         . I $D(SDDX1),SORT1'=2 W ?117,SDDX1
    59         S Y=1
    60 PRNTQ   S:QFLAG Y=0 Q (Y)
    61         ;
    62 HDR(SDIV)       ;
    63         N Y
    64         S Y=0
    65         I SDVC'="",$E(IOST,1,2)="C-" D  G:QFLAG HDRQ
    66         . K DIR S DIR(0)="FO",DIR("A")="Press RETURN to continue or '^' to exit"
    67         . S DIR("?",1)="Pressing any key other than the '^' key will scroll to the next screen",DIR("?")="The '^' key will exit the listing."
    68         . D ^DIR K DIR I $D(DTOUT)!($D(DUOUT)) S QFLAG=1 Q
    69         . W @IOF
    70         S PAGE=PAGE+1
    71         I $E(IOST,1,2)'="C-",SDVC'="" W @IOF
    72         W !!,"Provider/Diagnosis Encounter Report sorted by ",$P($T(SORT+SORT1^SDAMODO1),";;",2)," and ",$P($T(SORT+SORT2^SDAMODO1),";;",2)
    73         W ?(IOM-40),"Report Date: ",$P($$NOW^VALM1,"@"),?(IOM-10),"Page: ",PAGE
    74         W !,"Inclusion Dates: ",$P($$FMTE^XLFDT(SDBEG,1),"@")," to ",$P($$FMTE^XLFDT(SDEND,1),"@")
    75         W !,"Division: ",$P($G(^DG(40.8,SDIV,0)),U)
    76         W !!,"PATIENT",?32,"ENCOUNTER DATE",?55,"CLINIC/PRIMARY STOP CODE",?90,"PROVIDER",?117,"DX CODE"
    77         W !,"-------------------",?32,"------------------",?55,"------------------------",?90,"--------------",?117,"-------"
    78         S Y=1
    79 HDRQ    Q (Y)
    80         ;
    81 NOREP   ;
    82         W !!,"Provider/Diagnosis Report sorted by ",$P($T(SORT+SORT1^SDAMODO1),";;",2)," and ",$P($T(SORT+SORT2^SDAMODO1),";;",2)
    83         W ?(IOM-40),"Report Date: ",$P($$NOW^VALM1,"@")
    84         W !,"Inclusion Dates: ",$P($$FMTE^XLFDT(SDBEG,1),"@")," to ",$P($$FMTE^XLFDT(SDEND,1),"@")
    85         W !!,"No data found matching sort parameters"
    86         Q
    87         ;
    88 SELPRV(PRV)     ;
    89         N Y S Y=1
    90         I PROVDR=1 G SELPRVQ
    91         I $D(PROVDR($P(PRV,"^",2))) G SELPRVQ
    92         S Y=0
    93 SELPRVQ Q (Y)
    94         ;
    95 SELDX(DX)       ;
    96         N Y S Y=1
    97         I PDIAG=1 G SELDXQ
    98         S DIC="^ICD9(",DIC(0)="XMS",X=DX_" "  ;SD/529
    99         D ^DIC K DIC I Y<0 S Y=0 G SELDXQ
    100         I $D(PDIAG($P(Y,U))) G SELDXQ
    101         S Y=0
    102 SELDXQ  Q (Y)
     1SDAMODO3 ;ALB/SCK - PROVIDER DIAGNOSTICS REPORT OUTPUT ; 05 Oct 98  8:44 PM
     2 ;;5.3;Scheduling;**11,25,46,49,159**;Aug 13, 1993
     3 Q
     4REPORT ;
     5 I '$D(^TMP("SDRPT",$J)) D NOREP G EXIT
     6START ;
     7 N SDIV,OEN,SDPRX,SUB1,SUB2,OEN,SDATA,SDX,SPRV,SDCHECK
     8 S (SDIV,SDFIN,SDVC,SUBX,SUB1,SUB2)="",(PAGE,QFLAG,SUBCNT)=0
     9 W:$E(IOST,1,2)="C-" @IOF
     10 F  S SDIV=$O(^TMP("SDRPT",$J,SDIV)) Q:SDIV=""  D  Q:SDFIN
     11 . I SDIV'=SDVC S SUBX=$$SUBCNT(SUB1,SUBX),SDFIN='$$HDR(SDIV) Q:SDFIN  S SDVC=SDIV
     12 . S SUB1="" F  S SUB1=$O(^TMP("SDRPT",$J,SDIV,SUB1)) Q:SUB1=""  D  Q:SDFIN
     13 .. I SUBX'=SUB1 S SUBX=$$SUBCNT(SUB1,SUBX)
     14 .. I SORT1=4!(SORT1=5) I SUBX]"",SUBX'=SUB1 S SDFIN='$$HDR(SDIV)
     15 .. S SUB2="" F  S SUB2=$O(^TMP("SDRPT",$J,SDIV,SUB1,SUB2)) Q:SUB2=""  D  Q:SDFIN
     16 ... S OEN=0 F  S OEN=$O(^TMP("SDRPT",$J,SDIV,SUB1,SUB2,OEN)) Q:'OEN  S SUBCNT=SUBCNT+1,SDCHECK="" D  Q:SDFIN
     17 .... S I=0 F  S I=$O(^TMP("SDRPT",$J,SDIV,SUB1,SUB2,OEN,I)) Q:'I  S SDFIN='$$PRNT(I) Q:SDFIN
     18 S SUBX=$$SUBCNT(SUB1,SUBX)
     19EXIT ;
     20 K QFLAG,PAGE,SDFIN,SDVC,SDONE,XX,^TMP("SDRPT",$J),SUBCNT,SUBX
     21 Q
     22 ;
     23SUBCNT(SB1,SB1P) ;
     24 I SB1P']""!(SUBCNT'>0) G SUBCNTQ
     25 W !,SUBCNT," ",$S(SORT2=1!(SORT2=2):"Primary "_$P($T(SORT+SORT2^SDAMODO1),";;",2),1:$P($T(SORT+SORT2^SDAMODO1),";;",2))," entries for ",$S(SORT1=1!(SORT1=3):$P(SB1P,"^"),SORT1=5:$P($G(^DIC(40.7,SB1P,0)),U),1:SB1P),!!
     26 S SUBCNT=0
     27SUBCNTQ Q (SB1)
     28 ;
     29PRNT(I) ;
     30 N Y,SDATA,SPRV,SDX,XX,SCODE,SDDX1,SDPRX,SDSID
     31 S SDATA=(^TMP("SDRPT",$J,SDIV,SUB1,SUB2,OEN,I,0))
     32 S XX="" F  S XX=$O(^TMP("SDRPT",$J,SDIV,SUB1,SUB2,OEN,I,"PRV",XX)) Q:'XX  S SPRV(XX)=""
     33 S XX="" F  S XX=$O(^TMP("SDRPT",$J,SDIV,SUB1,SUB2,OEN,I,"DX",XX)) Q:XX=""  S SDX(XX)=""
     34 I SORT1=1,'$$SELPRV(SUB1) S Y=1 G PRNTQ
     35 I SORT1=2,'$$SELDX(SUB1) S Y=1 G PRNTQ
     36 I $Y+5>IOSL  S Y='$$HDR(SDIV) G:Y PRNTQ
     37LINE1 ;
     38 S SDSID=$P($G(SDATA),U,2)
     39 W !,$P(^DPT($P($G(SDATA),U),0),U)_" "_$P(SDSID,"-",3)
     40 S:SDCHECK="" SDCHECK=SDSID I SDSID'=SDCHECK S SUBCNT=SUBCNT+1
     41 W ?32,$P($$FMTE^XLFDT(OEN,1),":",1,2) ; modified to drop seconds
     42 W ?55,$E($P(SDATA,U,3),1,25)
     43 W ?90,$S(+$P(SDATA,U,5)>0:$P(^VA(200,+$P(SDATA,U,5),0),U),1:$P(SDATA,U,5))
     44 W ?117,$P(SDATA,U,6)
     45LINE2 ;
     46 S SCODE=$P(SDATA,U,4)
     47 W !?56,$P($G(^DIC(40.7,+SCODE,0)),U,2),"/",$P($G(^DIC(40.7,+SCODE,0)),U)
     48 S SDPRX="",SDPRX=$O(SPRV(SDPRX)) I $D(SDPRX),SORT1'=1 W ?90,$S(+SDPRX>0:$P(^VA(200,SDPRX,0),U),1:"")
     49 S SDDX1="",SDDX1=$O(SDX(SDDX1)) I $D(SDDX1),SORT1'=2 W ?117,SDDX1
     50 S SDONE=0
     51 F XX=1:1 D  Q:SDONE
     52 . I SDDX1'="" S SDDX1=$O(SDX(SDDX1))
     53 . I SDPRX'="" S SDPRX=$O(SPRV(SDPRX))
     54 . I SDPRX']""&(SDDX1']"") S SDONE=1 Q
     55 . I $Y+5>IOSL S SDONE='$$HDR(SDIV) Q:SDONE
     56 . W !
     57 . I $D(SDPRX),SORT1'=1 W ?90,$S(+SDPRX>0:$P(^VA(200,SDPRX,0),U),1:"")
     58 . I $D(SDDX1),SORT1'=2 W ?117,SDDX1
     59 S Y=1
     60PRNTQ S:QFLAG Y=0 Q (Y)
     61 ;
     62HDR(SDIV) ;
     63 N Y
     64 S Y=0
     65 I SDVC'="",$E(IOST,1,2)="C-" D  G:QFLAG HDRQ
     66 . K DIR S DIR(0)="FO",DIR("A")="Press RETURN to continue or '^' to exit"
     67 . S DIR("?",1)="Pressing any key other than the '^' key will scroll to the next screen",DIR("?")="The '^' key will exit the listing."
     68 . D ^DIR K DIR I $D(DTOUT)!($D(DUOUT)) S QFLAG=1 Q
     69 . W @IOF
     70 S PAGE=PAGE+1
     71 I $E(IOST,1,2)'="C-",SDVC'="" W @IOF
     72 W !!,"Provider/Diagnosis Encounter Report sorted by ",$P($T(SORT+SORT1^SDAMODO1),";;",2)," and ",$P($T(SORT+SORT2^SDAMODO1),";;",2)
     73 W ?(IOM-40),"Report Date: ",$P($$NOW^VALM1,"@"),?(IOM-10),"Page: ",PAGE
     74 W !,"Inclusion Dates: ",$P($$FMTE^XLFDT(SDBEG,1),"@")," to ",$P($$FMTE^XLFDT(SDEND,1),"@")
     75 W !,"Division: ",$P($G(^DG(40.8,SDIV,0)),U)
     76 W !!,"PATIENT",?32,"ENCOUNTER DATE",?55,"CLINIC/PRIMARY STOP CODE",?90,"PROVIDER",?117,"DX CODE"
     77 W !,"-------------------",?32,"------------------",?55,"------------------------",?90,"--------------",?117,"-------"
     78 S Y=1
     79HDRQ Q (Y)
     80 ;
     81NOREP ;
     82 W !!,"Provider/Diagnosis Report sorted by ",$P($T(SORT+SORT1^SDAMODO1),";;",2)," and ",$P($T(SORT+SORT2^SDAMODO1),";;",2)
     83 W ?(IOM-40),"Report Date: ",$P($$NOW^VALM1,"@")
     84 W !,"Inclusion Dates: ",$P($$FMTE^XLFDT(SDBEG,1),"@")," to ",$P($$FMTE^XLFDT(SDEND,1),"@")
     85 W !!,"No data found matching sort parameters"
     86 Q
     87 ;
     88SELPRV(PRV) ;
     89 N Y S Y=1
     90 I PROVDR=1 G SELPRVQ
     91 I $D(PROVDR($P(PRV,"^",2))) G SELPRVQ
     92 S Y=0
     93SELPRVQ Q (Y)
     94 ;
     95SELDX(DX) ;
     96 N Y S Y=1
     97 I PDIAG=1 G SELDXQ
     98 S DIC="^ICD9(",DIC(0)="MZ",X=DX
     99 D ^DIC K DIC I Y<0 S Y=0 G SELDXQ
     100 I $D(PDIAG($P(Y,U))) G SELDXQ
     101 S Y=0
     102SELDXQ Q (Y)

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDAMVSC.m

    r613 r623  
    1 SDAMVSC ;;OIFO-BAY PINES/TEH - Appt Event Driver Utilities-Validate SC Appt type ; 12/1/91 [ 09/19/96  1:39 PM ]  ; Compiled August 20, 2007 14:28:26
    2         ;;5.3;Scheduling;**394,417,491**;Aug 13, 1993;Build 53
    3         ;
    4         ;
    5         ;***************************************************************************************************************************
    6         ;
    7         ;                            ***** NOTE *****
    8         ;                                                   
    9         ;This software was created to be used with the SCHEDULING V5.3 appointment management package. The SRA API (SDAMA301)
    10         ;was employed to retrieve data from the PATIENT APPOINTMENT file (2.98) due inpart to VA Fileman non-compliance.
    11         ;
    12         ;DBIA #4433 SUBSCRIPTION
    13         ;
    14         ;
    15         ;Entry Point EN. This routine requires the OUTPATIENT ENOUNTER IEN (variable SDOE)
    16         ;
    17         ;GLOBALS: ^SCE(IEN,0) (#.1) APPOINTMENT TYPE [10P:409.1]
    18         ;         ^DPT(IEN,"S",DATE,0)  ^ (#9.5) APPOINTMENT TYPE [16P:409.1]
    19         ;         ^SD(409.41,0)=OUTPATIENT CLASSIFCATION TYPE "Was treatment for SC Condition? " QUESTION FOR CHECKOUT.
    20         ;
    21         ;PROTOCOLS: This routine is called from the SDAM APPOINTMENT EVENTS.
    22         ;         
    23         ;This validates that both the OUTPATIENT ENCOUNTER and the PATIENT SCHEDULING NODES for APPOINTMENT TYPE are (pointer to
    24         ;409.1 APPOINTMENT TYPE) are set to the "SERVICE CONNECTED" appointment type when the response to the CLASSIFICATION TYPE
    25         ;"Was treatment for SC Condition?" question is answered "YES". If the question is answered "NO" and the APPOINTMENT TYPE
    26         ;is SERVICE CONNECTED, then the APPOINTMENT TYPE is reverted to REGULAR.
    27         ;
    28         ;
    29         ;****************************************************************************************************************************
    30         Q
    31 EN      ;Entry Point
    32         Q:'$G(SDOE)
    33         N SDN,SDVSCL,SDVSTD,SDAPDF,SDDPTYP,SDOED,SDVSTD,SDVDPTD,SDVSCD,SDSCV,SDAPPTY,SDAPDT,SDDFN,SDVSTD,SDIENS,SDARRAY,SDAPDF
    34         S SDOED=$G(^SCE(SDOE,0)) Q:SDOED=""
    35         S SDDFN=$P(SDOED,U,2),SDAPDT=$P(SDOED,U)
    36         ;GET APPOINTMENT FROM EVENT OUTPUT ARRAY
    37         I $G(^TMP("SDAMEVT",$J,"AFTER","DPT")) S SDAPDPT=$P($G(^TMP("SDAMEVT",$J,"AFTER","DPT")),"^",16)
    38         E  S SDAPDPT=$P(SDOED,"^",10) ;APP TYPE
    39         S SDVSCL=$P(SDOED,U,4)
    40         S SDVSTD=$P(SDOED,U,5)
    41         Q:'SDVSTD  ; ticket #194210 ; do not proceed if no pointer to a visit
    42         Q:'$D(^AUPNVSIT(SDVSTD,800))
    43         S SDSCV=+$$GET1^DIQ(9000010,SDVSTD_",",80001,"I") ;SC flag in Visit file
    44         S SDAPDF=$$GET1^DIQ(44,SDVSCL_",",2507,"I") ;default appt type
    45         ;find if credit stop secondary visit exists.
    46         N SDVSTDS,SDOE1 S SDOE1="" S SDVSTDS=$O(^AUPNVSIT("AD",SDVSTD,""))
    47         I SDVSTDS>0 S SDOE1=$O(^SCE("AVSIT",SDVSTDS,""))
    48         I SDSCV I SDAPDPT'=11 S SDAPDPT=11 D APPT F SDE=SDOE,SDOE1 I SDE>0 D SCE(SDE)
    49         I 'SDSCV I SDAPDPT=11 D  D APPT F SDE=SDOE,SDOE1 I SDE>0 D SCE(SDE)
    50         . I SDAPDF'="" S SDAPDPT=SDAPDF ; set to default if exists for this clinic
    51         . E  S SDAPDPT=9 ; set to regular
    52         Q
    53 SCE(SDE)        ;Set FDA for SCE(ien,0) OUTPATIENT ENCOUNTER
    54         S SDIENS=SDE_"," K ^TMP("SDAMSCE",$J)
    55         D FDA^DILF(409.68,SDIENS,.1,,SDAPDPT,"^TMP(""SDAMSCE"",$J)","^TMP(""SDAMSCE"",$J)")
    56         I $D(^TMP("SDAMSCE",$J,"DIERR")) D  Q
    57         .W !,"Processing Error ",^TMP("SDAMSCE",$J,"DIERR",1) Q
    58         D FILE^DIE(,"^TMP(""SDAMSCE"",$J)","^TMP(""SDAMSCE"",$J)")
    59         Q
    60 APPT    ;quit if clinic in event doesn't match clinic in ^DPT
    61         ;set up app type in DPT
    62         I +$G(^TMP("SDAMEVT",$J,"AFTER","DPT"))'=+$G(^DPT(SDDFN,"S",SDAPDT,0)) Q
    63         I $D(^DPT(SDDFN,"S",SDAPDT,0)) S $P(^DPT(SDDFN,"S",SDAPDT,0),U,16)=SDAPDPT
    64 END     Q
     1SDAMVSC ;;OIFO-BAY PINES/TEH - Appt Event Driver Utilities-Validate SC Appt type ; 12/1/91 [ 09/19/96  1:39 PM ]
     2 ;;5.3;Scheduling;**394,417**;Aug 13, 1993
     3 ;
     4 ;***************************************************************************************************************************
     5 ;
     6 ;                                                   ***** NOTE *****
     7 ;                                                   
     8 ;This software was created to be used with the SCHEDULING V5.3 appointment management package. The SRA API (SDAMA301)
     9 ;was employed to retrieve data from the PATIENT APPOINTMENT file (2.98) due inpart to VA Fileman non-compliance.
     10 ;
     11 ;DBIA #4433 SUBSCRIPTION
     12 ;
     13 ;Entry Point EN. This routine requires the OUTPATIENT ENOUNTER IEN (variable SDOE)
     14 ;
     15 ;GLOBALS: ^SCE(IEN,0) (#.1) APPOINTMENT TYPE [10P:409.1]
     16 ;         ^DPT(IEN,"S",DATE,0)  ^ (#9.5) APPOINTMENT TYPE [16P:409.1]
     17 ;         ^SD(409.41,0)=OUTPATIENT CLASSIFCATION TYPE "Was treatment for SC Condition? " QUESTION FOR CHECKOUT.
     18 ;
     19 ;PROTOCOLS: This routine is called from the SDAM APPOINTMENT EVENTS.
     20 ;         
     21 ;This validates that both the OUTPATIENT ENCOUNTER and the PATIENT SCHEDULING NODES for APPOINTMENT TYPE are (pointer to
     22 ;409.1 APPOINTMENT TYPE) are set to the "SERVICE CONNECTED" appointment type when the response to the CLASSIFICATION TYPE
     23 ;"Was treatment for SC Condition?" question is answered "YES". If the question is answered "NO" and the APPOINTMENT TYPE
     24 ;is SERVICE CONNECTED, then the APPOINTMENT TYPE is reverted to REGULAR.
     25 ;
     26 ;
     27 ;****************************************************************************************************************************
     28 Q
     29EN ;Entry Point
     30 G END:'$D(SDOE),END:'$G(SDOE),END:SDOE=""
     31 N SDVSCL,SDVSTD,SDAPDF,SDDPTYP,SDOED,SDVSTD,SDVDPTD,SDVSCD,SDSCV,SDAPPTY,SDAPDT,SDDFN,SDVSTD,SDIENS,SDARRAY,SDAPDF
     32 S SDOED=$G(^SCE(SDOE,0)) G END:SDOED=""
     33 S SDDFN=$P(SDOED,U,2),SDAPDT=$P(SDOED,U) I '$D(^DPT(SDDFN,"S",SDAPDT,0)) Q
     34 ;GET APPOINTMENT FROM 2.98
     35 N SDAMIENS S SDAMIENS=SDAPDT_","_SDDFN_","
     36 S SDAPDPT=$$GET1^DIQ(2.98,SDAMIENS,9.5,"I")
     37 S SDVSCL=$P(SDOED,U,4)
     38 S SDVSTD=$P(SDOED,U,5),SDSCV=$$GET1^DIQ(9000010,SDVSTD_",",80001,"I")
     39 S SDAPDF=$$GET1^DIQ(44,SDVSCL_",",2507,"I")
     40 S SDAPPTY=$S(SDSCV=1:11,$D(SDAPDPT):SDAPDPT,SDAPDT'="":SDAPDF,1:9) D
     41 .;Set FDA for SCE(ien,0) OUTPATIENT ENCOUNTER
     42 .S SDIENS=SDOE_"," K ^TMP("SDAMSCE",$J)
     43 .D FDA^DILF(409.68,SDIENS,.1,,SDAPPTY,"^TMP(""SDAMSCE"",$J)","^TMP(""SDAMSCE"",$J)")
     44 .I $D(^TMP("SDAMSCE",$J,"DIERR")) D
     45 ..W !,"Processing Error ",^TMP("SDAMSCE",$J,"DIERR",1) Q
     46 .D FILE^DIE(,"^TMP(""SDAMSCE"",$J)","^TMP(""SDAMSCE"",$J)")
     47 .;Set FDA for ^DPT(ien,"S") PATIENT APPOINTMENT.
     48 .K ^TMP($J,"SDAMA301")
     49 .N SDAMVSCX S SDARRAY(1)=SDAPDT_";"_SDAPDT,SDARRAY(4)=SDDFN,SDARRAY("FLDS")=10,SDAMVSCX=$$SDAPI^SDAMA301(.SDARRAY)
     50 .I 'SDAMVSCX D  Q
     51 ..W !,"Processing Error "
     52 .S SDDPTYP=+$P($G(^TMP($J,"SDAMA301",SDDFN,SDVSCL,SDAPDT)),U,10) I SDDPTYP'=SDAPPTY D
     53 ..S $P(^DPT(SDDFN,"S",SDAPDT,0),U,16)=SDAPPTY
     54END Q

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDC.m

    r613 r623  
    1 SDC     ;MAN/GRR,ALB/LDB - CANCEL A CLINIC'S AVAILABILITY ; 3/2/05 2:11pm
    2         ;;5.3;Scheduling;**15,32,79,132,167,478,487,523**;Aug 13, 1993;Build 6
    3         N SDATA,SDCNHDL ; for evt dvr
    4 SDC1    K SDLT,SDCP S NOAP="" D LO^DGUTL
    5         S DIC=44,DIC(0)="MEQA",DIC("S")="I $P(^(0),""^"",3)=""C"",'$G(^(""OOS""))",DIC("A")="Select CLINIC NAME: " D ^DIC K DIC("S"),DIC("A") G:'$D(^SC(+Y,"SL")) END^SDC0
    6         S SC=+Y,SL=^("SL"),%DT="AEXF",%DT("A")="CANCEL '"_$P(Y,U,2)_"' FOR WHAT DATE: " D ^%DT K %DT G:Y<0 END^SDC0 ;NAKED REFERNCE - ^SC(IFN,"SL")
    7         S (SD,CDATE)=Y,%=$P(SL,U,6),SI=$S(%="":4,%<3:4,%:%,1:4),%=$P(SL,U,3),STARTDAY=$S($L(%):%,1:8) D NOW^%DTC S SDTIME=%
    8         K SDRE,SDIN,SDRE1 I $D(^SC(SC,"I")) S SDIN=+^("I"),SDRE=+$P(^("I"),"^",2),Y=SDRE D:Y DTS^SDUTL S SDRE1=$S(SDRE:" to "_Y,1:"")
    9         I $S('$D(SDIN):0,SDIN'>0!(SDIN>SD):0,SDRE'>SD&(SDRE):0,1:1) W !,*7,"Clinic is inactive ",$S('SDRE:"as of ",1:"from ") S Y=SDIN D DTS^SDUTL W Y,SDRE1 G SDC1
    10         I '$D(^SC(SC,"ST",SD,1)) S DH="" D B S ^SC(SC,"ST",SD,1)=$P("SU^MO^TU^WE^TH^FR^SA",U,DOW+1)_" "_$E(SD,6,7)_$J("",SI+SI-6)_DH,^(0)=SD G N
    11         I ^(1)["CANCELLED" W !,"APPOINTMENTS HAVE ALREADY BEEN CANCELLED",!,*7 S ANS="N",SDTIME="*",SDV1=$S($P(^SC(SC,0),"^",15):$P(^(0),"^",15),1:+$O(^DG(40.8,0))) K SDX G ASKL^SDC0 ;NAKED REFERENCE - ^SC(IFN,"ST",Date,1)
    12 N       I '$F(^SC(SC,"ST",SD,1),"[") K:^(1)?2U.E ^SC(SC,"ST",SD) W !,*7,"CLINIC DOES NOT MEET ON THAT DAY" G SDC1 ; KILLs node if not holiday
    13         I $O(^SC(SC,"S",SD))\1-SD W *7,!?5,"NO APPOINTMENTS SCHEDULED" S NOAP=1 G W
    14         W !,"FIRST, I'LL LIST THE EXISTING APPOINTMENTS",!
    15         K DUOUT,DTOUT D ^SDC1 I $D(DUOUT)!$D(DTOUT) D END^SDC0 Q
    16         I ^SC(SC,"ST",SD,1)["X" G ^SDC2
    17 W       S DH=0,%="" W !,"WANT TO CANCEL THE WHOLE DAY" D YN^DICN I '% W !,"REPLY YES (Y) OR NO (N)" G W
    18         I %=1 G WP:$$COED^SDC4(SC,SD,SD+.2359,1),ALL
    19         Q:%<1
    20 WP      S %="" W !,"WANT TO CANCEL PART OF THE DAY" D YN^DICN I '% W !,"REPLY YES (Y) OR NO (N)" G WP
    21         Q:(%-1)
    22 F       R !,"STARTING TIME: ",X:DTIME Q:U[X  D TC^SDC2 G F:Y<0 S FR=Y,ST=%
    23 T       R !,"ENDING TIME: ",X:DTIME Q:U[X  D TC^SDC2 G T:Y<0 S SDHTO=X,TO=Y I TO'>FR W !,"Ending time must be greater than starting time",*7 G T
    24         I $$COED^SDC4(SC,FR,TO,1) K FR,SDHTO,TO,ST W ! G F
    25 ROPT    R !,"Reason for cancellation:  ",I:DTIME I I?1"?".E W !,"YOU MAY ENTER A MESSAGE CONCERNING THE CANCELLATION HERE" G ROPT
    26         N CANREM S CANREM=I
    27         Q:I["^"  I '$D(^SC(SC,"SDCAN",0)) S ^SC(SC,"SDCAN",0)="^44.05D^"_FR_"^1" G SKIP
    28         S A=^SC(SC,"SDCAN",0),SDCNT=$P(A,"^",4),^SC(SC,"SDCAN",0)=$P(A,"^",1,2)_"^"_FR_"^"_(SDCNT+1)
    29 SKIP    S ^SC(SC,"SDCAN",FR,0)=FR_"^"_SDHTO
    30         S NOAP=$S($O(^SC(SC,"S",(FR-.0001)))'>0:1,$O(^SC(SC,"S",(FR-.0001)))>TO:1,1:0) I 'NOAP S NOAP=$S($O(^SC(SC,"S",+$O(^SC(SC,"S",(FR-.0001))),0))="MES":1,1:0)
    31         S ^SC(SC,"S",FR,0)=FR,^("MES")="CANCELLED UNTIL "_X_$S(I?.P:"",1:" ("_I_")") D S S I=^(1),I=I_$J("",%-$L(I)),Y=""
    32         F X=0:2:% S DH=$E(I,X+SI+SI),P=$S(X<ST:DH_$E(I,X+1+SI+SI),X=%:$S(Y="[":Y,1:DH)_$E(I,X+1+SI+SI),1:$S(Y="["&(X=ST):"]",1:"X")_"X"),Y=$S(DH="]":"",DH="[":DH,1:Y),I=$E(I,1,X-1+SI+SI)_P_$E(I,X+2+SI+SI,999)
    33         S:'$F(I,"[") I5=$F(I,"X"),I=$E(I,1,(I5-2))_"["_$E(I,I5,999) K I5
    34         S DH=0,^(1)=I,FR=FR-.0001 G C ;NAKED REFERENCE - ^SC(IFN,"ST",Date,1)
    35 S       S ^("CAN")=^SC(SC,"ST",SD,1) Q
    36         ;
    37 ALL     N CANREM
    38         W !,"Reason for cancellation: " R CANREM:DTIME I $L(CANREM)>160!($L(CANREM)<3) W !,*7,"Reason must be between 3 to 160 characters long",! G ALL
    39         D S S ^(1)="   "_$E(SD,6,7)_"    **CANCELLED**",FR=SD,TO=SD+.9 ;NAKED REFERENCE - ^SC(IFN,"ST",Date,1)
    40 C       S FR=$O(^SC(SC,"S",FR)) I FR<1!(FR'<TO) W !!,"CANCELLED!  " K SDX G CHKEND^SDC0
    41         N TDH,TMPD,DIE,DR,NODE
    42         F I=0:0 S I=$O(^SC(SC,"S",FR,1,I)) Q:I'>0  D
    43         .S DFN=+^SC(SC,"S",FR,1,I,0),SDCNHDL=$$HANDLE^SDAMEVT(1)
    44         .D BEFORE^SDAMEVT(.SDATA,DFN,FR,SC,I,SDCNHDL)
    45         .S $P(^SC(SC,"S",FR,1,I,0),"^",9)="C"
    46         .S:$D(^DPT(DFN,"S",FR,0)) NODE=^(0)  ;added SD/523
    47         .Q:$P(NODE,U,1)'=SC                  ;added SD/523
    48         .S ^DPT("ASDCN",SC,FR,DFN)=""
    49         .S SDSC=SC,SDTTM=FR,SDPL=I,TDH=DH,TMPD=CANREM D CANCEL^SDCNSLT S DH=TDH ;SD/478
    50         .I $D(^DPT(DFN,"S",FR,0)),$P(^(0),"^",2)'["C" S $P(^(0),"^",2)="C",$P(^(0),"^",12)=DUZ,$P(^(0),"^",14)=SDTIME,DH=DH+1,TDH=DH,DIE="^DPT(DFN,"_"""S"""_",",DR="17///^S X=CANREM",DA=FR D ^DIE S DH=TDH D MORE
    51         G C
    52         ;
    53 B       S X=SD D DOW^SDM0 S DOW=Y,SS=+$O(^SC(SC,"T"_Y,X)) I $D(^(SS,1)),^(1)]"" S DH=^(1),DO=X+1,DA(1)=SC
    54         Q
    55 MORE    I $D(^SC("ARAD",SC,FR,DFN)) S ^(DFN)="N"
    56         S SDIV=$S($P(^SC(SC,0),"^",15)]"":$P(^(0),"^",15),1:" 1"),SDV1=$S(SDIV:SDIV,1:+$O(^DG(40.8,0))) I $D(^DPT("ASDPSD","C",SDIV,SC,FR,DFN)) K ^(DFN)
    57         S SDH=DH,SDTTM=FR,SDSC=SC,SDPL=I,SDRT="D" D RT^SDUTL
    58         S DH=SDH K SDH D CK1,EVT
    59         K SD1,SDIV,SDPL,SDRT,SDSC,SDTTM,SDX Q
    60 CK1     S SDX=0 F SD1=FR\1:0 S SD1=$O(^DPT(DFN,"S",SD1)) Q:'SD1!((SD1\1)'=(FR\1))  I $P(^(SD1,0),"^",2)'["C",$P(^(0),"^",2)'["N" S SDX=1 Q
    61         Q:SDX  F SD1=2,4 I $D(^SC("AAS",SD1,FR\1,DFN)) S SDX=1 Q
    62         Q:SDX  IF $D(^SCE(+$$EXAE^SDOE(DFN,FR\1,FR\1),0)) S SDX=1
    63         Q:SDX  K ^DPT("ASDPSD","B",SDIV,FR\1,DFN) Q
    64         ;
    65 EVT     ; -- separate tag if need to NEW vars
    66         ; -- cancel event
    67         N FR,I,SDTIME,DH,SC
    68         D CANCEL^SDAMEVT(.SDATA,DFN,SDTTM,SDSC,SDPL,0,SDCNHDL) K SDATA,SDCNHDL
    69         Q
     1SDC ;MAN/GRR,ALB/LDB - CANCEL A CLINIC'S AVAILABILITY ; 3/2/05 2:11pm
     2 ;;5.3;Scheduling;**15,32,79,132,167,478,487**;Aug 13, 1993
     3 N SDATA,SDCNHDL ; for evt dvr
     4SDC1 K SDLT,SDCP S NOAP="" D LO^DGUTL
     5 S DIC=44,DIC(0)="MEQA",DIC("S")="I $P(^(0),""^"",3)=""C"",'$G(^(""OOS""))",DIC("A")="Select CLINIC NAME: " D ^DIC K DIC("S"),DIC("A") G:'$D(^SC(+Y,"SL")) END^SDC0
     6 S SC=+Y,SL=^("SL"),%DT="AEXF",%DT("A")="CANCEL '"_$P(Y,U,2)_"' FOR WHAT DATE: " D ^%DT K %DT G:Y<0 END^SDC0 ;NAKED REFERNCE - ^SC(IFN,"SL")
     7 S (SD,CDATE)=Y,%=$P(SL,U,6),SI=$S(%="":4,%<3:4,%:%,1:4),%=$P(SL,U,3),STARTDAY=$S($L(%):%,1:8) D NOW^%DTC S SDTIME=%
     8 K SDRE,SDIN,SDRE1 I $D(^SC(SC,"I")) S SDIN=+^("I"),SDRE=+$P(^("I"),"^",2),Y=SDRE D:Y DTS^SDUTL S SDRE1=$S(SDRE:" to "_Y,1:"")
     9 I $S('$D(SDIN):0,SDIN'>0!(SDIN>SD):0,SDRE'>SD&(SDRE):0,1:1) W !,*7,"Clinic is inactive ",$S('SDRE:"as of ",1:"from ") S Y=SDIN D DTS^SDUTL W Y,SDRE1 G SDC1
     10 I '$D(^SC(SC,"ST",SD,1)) S DH="" D B S ^SC(SC,"ST",SD,1)=$P("SU^MO^TU^WE^TH^FR^SA",U,DOW+1)_" "_$E(SD,6,7)_$J("",SI+SI-6)_DH,^(0)=SD G N
     11 I ^(1)["CANCELLED" W !,"APPOINTMENTS HAVE ALREADY BEEN CANCELLED",!,*7 S ANS="N",SDTIME="*",SDV1=$S($P(^SC(SC,0),"^",15):$P(^(0),"^",15),1:+$O(^DG(40.8,0))) K SDX G ASKL^SDC0 ;NAKED REFERENCE - ^SC(IFN,"ST",Date,1)
     12N I '$F(^SC(SC,"ST",SD,1),"[") K:^(1)?2U.E ^SC(SC,"ST",SD) W !,*7,"CLINIC DOES NOT MEET ON THAT DAY" G SDC1 ; KILLs node if not holiday
     13 I $O(^SC(SC,"S",SD))\1-SD W *7,!?5,"NO APPOINTMENTS SCHEDULED" S NOAP=1 G W
     14 W !,"FIRST, I'LL LIST THE EXISTING APPOINTMENTS",!
     15 K DUOUT,DTOUT D ^SDC1 I $D(DUOUT)!$D(DTOUT) D END^SDC0 Q
     16 I ^SC(SC,"ST",SD,1)["X" G ^SDC2
     17W S DH=0,%="" W !,"WANT TO CANCEL THE WHOLE DAY" D YN^DICN I '% W !,"REPLY YES (Y) OR NO (N)" G W
     18 I %=1 G WP:$$COED^SDC4(SC,SD,SD+.2359,1),ALL
     19 Q:%<1
     20WP S %="" W !,"WANT TO CANCEL PART OF THE DAY" D YN^DICN I '% W !,"REPLY YES (Y) OR NO (N)" G WP
     21 Q:(%-1)
     22F R !,"STARTING TIME: ",X:DTIME Q:U[X  D TC^SDC2 G F:Y<0 S FR=Y,ST=%
     23T R !,"ENDING TIME: ",X:DTIME Q:U[X  D TC^SDC2 G T:Y<0 S SDHTO=X,TO=Y I TO'>FR W !,"Ending time must be greater than starting time",*7 G T
     24 I $$COED^SDC4(SC,FR,TO,1) K FR,SDHTO,TO,ST W ! G F
     25ROPT R !,"Reason for cancellation:  ",I:DTIME I I?1"?".E W !,"YOU MAY ENTER A MESSAGE CONCERNING THE CANCELLATION HERE" G ROPT
     26 N CANREM S CANREM=I
     27 Q:I["^"  I '$D(^SC(SC,"SDCAN",0)) S ^SC(SC,"SDCAN",0)="^44.05D^"_FR_"^1" G SKIP
     28 S A=^SC(SC,"SDCAN",0),SDCNT=$P(A,"^",4),^SC(SC,"SDCAN",0)=$P(A,"^",1,2)_"^"_FR_"^"_(SDCNT+1)
     29SKIP S ^SC(SC,"SDCAN",FR,0)=FR_"^"_SDHTO
     30 S NOAP=$S($O(^SC(SC,"S",(FR-.0001)))'>0:1,$O(^SC(SC,"S",(FR-.0001)))>TO:1,1:0) I 'NOAP S NOAP=$S($O(^SC(SC,"S",+$O(^SC(SC,"S",(FR-.0001))),0))="MES":1,1:0)
     31 S ^SC(SC,"S",FR,0)=FR,^("MES")="CANCELLED UNTIL "_X_$S(I?.P:"",1:" ("_I_")") D S S I=^(1),I=I_$J("",%-$L(I)),Y=""
     32 F X=0:2:% S DH=$E(I,X+SI+SI),P=$S(X<ST:DH_$E(I,X+1+SI+SI),X=%:$S(Y="[":Y,1:DH)_$E(I,X+1+SI+SI),1:$S(Y="["&(X=ST):"]",1:"X")_"X"),Y=$S(DH="]":"",DH="[":DH,1:Y),I=$E(I,1,X-1+SI+SI)_P_$E(I,X+2+SI+SI,999)
     33 S:'$F(I,"[") I5=$F(I,"X"),I=$E(I,1,(I5-2))_"["_$E(I,I5,999) K I5
     34 S DH=0,^(1)=I,FR=FR-.0001 G C ;NAKED REFERENCE - ^SC(IFN,"ST",Date,1)
     35S S ^("CAN")=^SC(SC,"ST",SD,1) Q
     36 ;
     37ALL N CANREM
     38 W !,"Reason for cancellation: " R CANREM:DTIME I $L(CANREM)>160!($L(CANREM)<3) W !,*7,"Reason must be between 3 to 160 characters long",! G ALL
     39 D S S ^(1)="   "_$E(SD,6,7)_"    **CANCELLED**",FR=SD,TO=SD+.9 ;NAKED REFERENCE - ^SC(IFN,"ST",Date,1)
     40C S FR=$O(^SC(SC,"S",FR)) I FR<1!(FR'<TO) W !!,"CANCELLED!  " K SDX G CHKEND^SDC0
     41 N TDH,TMPD,DIE,DR
     42 F I=0:0 S I=$O(^SC(SC,"S",FR,1,I)) Q:I'>0  D
     43 .S DFN=+^SC(SC,"S",FR,1,I,0),SDCNHDL=$$HANDLE^SDAMEVT(1)
     44 .D BEFORE^SDAMEVT(.SDATA,DFN,FR,SC,I,SDCNHDL)
     45 .S $P(^SC(SC,"S",FR,1,I,0),"^",9)="C"
     46 .S ^DPT("ASDCN",SC,FR,DFN)=""
     47 .S SDSC=SC,SDTTM=FR,SDPL=I,TDH=DH,TMPD=CANREM D CANCEL^SDCNSLT S DH=TDH ;SD/478
     48 .I $D(^DPT(DFN,"S",FR,0)),$P(^(0),"^",2)'["C" S $P(^(0),"^",2)="C",$P(^(0),"^",12)=DUZ,$P(^(0),"^",14)=SDTIME,DH=DH+1,TDH=DH,DIE="^DPT(DFN,"_"""S"""_",",DR="17///^S X=CANREM",DA=FR D ^DIE S DH=TDH D MORE
     49 G C
     50 ;
     51B S X=SD D DOW^SDM0 S DOW=Y,SS=+$O(^SC(SC,"T"_Y,X)) I $D(^(SS,1)),^(1)]"" S DH=^(1),DO=X+1,DA(1)=SC
     52 Q
     53MORE I $D(^SC("ARAD",SC,FR,DFN)) S ^(DFN)="N"
     54 S SDIV=$S($P(^SC(SC,0),"^",15)]"":$P(^(0),"^",15),1:" 1"),SDV1=$S(SDIV:SDIV,1:+$O(^DG(40.8,0))) I $D(^DPT("ASDPSD","C",SDIV,SC,FR,DFN)) K ^(DFN)
     55 S SDH=DH,SDTTM=FR,SDSC=SC,SDPL=I,SDRT="D" D RT^SDUTL
     56 S DH=SDH K SDH D CK1,EVT
     57 K SD1,SDIV,SDPL,SDRT,SDSC,SDTTM,SDX Q
     58CK1 S SDX=0 F SD1=FR\1:0 S SD1=$O(^DPT(DFN,"S",SD1)) Q:'SD1!((SD1\1)'=(FR\1))  I $P(^(SD1,0),"^",2)'["C",$P(^(0),"^",2)'["N" S SDX=1 Q
     59 Q:SDX  F SD1=2,4 I $D(^SC("AAS",SD1,FR\1,DFN)) S SDX=1 Q
     60 Q:SDX  IF $D(^SCE(+$$EXAE^SDOE(DFN,FR\1,FR\1),0)) S SDX=1
     61 Q:SDX  K ^DPT("ASDPSD","B",SDIV,FR\1,DFN) Q
     62 ;
     63EVT ; -- separate tag if need to NEW vars
     64 ; -- cancel event
     65 N FR,I,SDTIME,DH,SC
     66 D CANCEL^SDAMEVT(.SDATA,DFN,SDTTM,SDSC,SDPL,0,SDCNHDL) K SDATA,SDCNHDL
     67 Q

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDCLAS.m

    r613 r623  
    1 SDCLAS  ;ALB/TMP,MRY - Clinic Assignment List Extract ;12/23/92  11:42
    2         ;;5.3;Scheduling;**63,243,517,523**;Aug 13, 1993;Build 6
    3         ;SD/517 CORRECTED ALL $NEXT FUNCTIONAL COMMANDS
    4         S DIV="" D DIV^SDUTL I $T D CALST^SDDIV Q:Y<0
    5         S:'$D(DTIME) DTIME=300 I '$D(DT) D DT^SDUTL
    6         S SDIFN="",SDI=0,DIC="^SC(",DIC(0)="EFMQ",DIC("S")="I $P(^(0),U,3)=""C"",'$G(^(""OOS"")),$S(DIV="""":1,$P(^(0),U,15)=DIV:1,1:0)" D SELECT^SDCLAS0 K DIC Q:X["^"
    7         S Y=DT D DTS^SDUTL S SDTS=Y
    8 OPT2    W !!,"Select 'As of' Date: ",SDTS," // " R X:DTIME Q:X["^"  I X']"" S SDTS=DT G OVR
    9         S %DT(0)=-DT,%DT="EPX" D ^%DT K %DT
    10         I Y'>0 W !,*7,"A date must be entered here to get a 'snapshot' of the clinic's enrollment as of",!,"  this date.  Date can not be in future." G OPT2
    11         S SDTS=+Y
    12 OVR     I SDSRT="C",SDSAV']"",SDIFN'="ALL",$S('$D(^SC(SDIFN,"I")):0,+^("I")=0:0,+^("I")>SDTS:0,+$P(^("I"),"^",2)'>SDTS&(+$P(^("I"),"^",2)'=0):0,1:1) W !,"Clinic ",$S(SDTS=DT:"is",1:"was")," inactive" W:SDTS<DT " on date selected" G END^SDCLAS1
    13         W !!,*7,"This needs to be printed at 132 columns"
    14         S PGM="START^SDCLAS",VAR="SDIFN^SDSRT^DIV^SDTS^SDSAV^SDFAST",VAL=SDIFN_"^"_SDSRT_"^"_DIV_"^"_SDTS_"^"_SDSAV_"^"_SDFAST D ZIS^DGUTQ Q:POP
    15 START   K ^UTILITY($J) S SDSTOP=$S(SDSRT="S":SDIFN,1:""),SD1="",U="^" U IO G:SDIFN="ALL"!(SDSRT="S")!(SDSAV]"") ALL
    16 ONE     S ONE=1 D INIT F SDAPPT=SDTS:0 S SDAPPT=$O(^SC(SDIFN,"S",SDAPPT)) Q:SDAPPT'>0  D PT
    17         D:'SDFAST AEB^SDCLAS0 G ^SDCLAS1
    18 ALL     S ONE=0 I SDSAV']"" S SDIFN=0 F  S SDIFN=$O(^SC(SDIFN)) Q:'SDIFN  I $P(^(SDIFN,0),"^",3)="C" D APPT
    19         I SDSAV]"" D APART S SDIFN=0 F  S SDIFN=$O(SDZ(SDIFN)) Q:'SDIFN  I $D(^SC(SDIFN,0)),$P(^(0),"^",3)="C" D APPT
    20         G ^SDCLAS1
    21 APPT    D CHECK I 'POP K ^UTILITY($J,"PAT",SDIFN) D INIT F SDAPPT=SDTS:0 S SDAPPT=$O(^SC(SDIFN,"S",SDAPPT)) D:SDAPPT>0 PT I SDAPPT'>0 D:'SDFAST AEB^SDCLAS0 Q
    22         Q
    23 PT      S SD=0 F  S SD=$O(^SC(SDIFN,"S",SDAPPT,1,SD)) Q:'SD  Q:'$D(^(SD,0))  S DFN=+^(0) D PT1
    24         Q
    25 PT1     I '$D(^UTILITY($J,"PAT",SDIFN,DFN)),$D(^DPT(DFN,0)),$D(^("S",SDAPPT,0)),$P(^(0),"^",2)=""!($P(^(0),"^",2)="I"),$S('$D(^DPT(DFN,.35)):1,'^(.35):1,1:0) D S,EXT^SDCLAS0
    26         Q
    27 S       S Y(0)=^DPT(DFN,0),SDACT=1,SDENR=0 D SET1
    28         S I=0 F  S I=$O(^DPT(DFN,"DE","B",SDIFN,I)) Q:'I  I $D(^DPT(DFN,"DE",I,0)) D EDENR Q:SDENR
    29         S ^UTILITY($J,"PAT",SDIFN,DFN)="" S:'$D(Y(1))!('SDENR) Y(1)="" I '$D(^UTILITY($J,"PAT"," ",DFN)) D MT S ^UTILITY($J,"PAT"," ",DFN)=$P(Y(0),"^",9)_"^"_SDELIG_"^"_SDZIP_"^"_$P(Y(0),"^",3)_U_SDMT
    30         Q
    31 EDENR   K Y(1) S I1=0 F  S I1=$O(^DPT(DFN,"DE",I,1,I1)) Q:'I1  S X=$P(^(I1,0),"^"),X(1)=$P(^(0),"^",3) Q:X>SDTS  S:'X(1)!(X(1)>SDTS) Y(1)=^(0),SDENR=1 Q:SDENR
    32         Q
    33 SET1    S SDELIG=$S($D(^DPT(DFN,.36)):$P(^(.36),"^",1),1:""),SDELIG=$S($D(^DIC(8,+SDELIG,0)):SDELIG,1:""),SDELIG(1)=$S(SDELIG]"":$P(^(0),"^",5),1:""),SDZIP=$S($D(^DPT(DFN,.11)):$P(^(.11),"^",6),1:"")
    34         Q
    35 MT      ;
    36         S SDMT="*" Q:SDELIG(1)']""  I SDELIG(1)="N" S SDMT="N" Q
    37         S SDMT=$$LST^DGMTU(DFN) I SDMT']"" S SDMT=$S(SDELIG'=6:"A",1:"X") Q
    38         S:$P(SDMT,U,2)>SDTS SDMT=$$LST^DGMTU(DFN,SDTS)
    39         I $P(SDMT,U,4)="P" S SDMT=$$PA^DGMTUTL($P(SDMT,U)),SDMT=$S('$D(SDMT):"U",SDMT="MT":"C",SDMT="GMT":"G",1:"U")
    40         E  S SDMT=$P(SDMT,U,4)
    41         I SDMT="" S SDMT="X"
    42         I SDMT="P" S SDMT="C"
    43         I SDMT="R" S SDMT="U"
    44         I SDMT="N" S SDMT="A"
    45         D DOM^SDOPC4(DFN,SDTS_.9,.SDMT) I SDMT="X0" S SDMT="X"
    46         K SDMT1 Q
    47 CHECK   S POP=0 I SDSRT="S",SDSTOP'="ALL",$P(^SC(SDIFN,0),"^",7)'=SDSTOP S POP=1 Q
    48         I $S(DIV="":1,$P(^SC(SDIFN,0),"^",15)=DIV:1,1:0),$S('$D(^SC(SDIFN,"I")):1,+^("I")=0:1,+^("I")>DT:1,+$P(^("I"),"^",2)'>DT&(+$P(^("I"),"^",2)'=0):1,1:0) Q
    49         S POP=1 Q
    50 APART   S SDZ="" F I=1:1 Q:$P(SDSAV,",",I)']""  S SDZ=$P(SDSAV,",",I) D:SDZ["--" SPLIT^SDCLAS0 I SDZ'["--" S:'$D(SDZ(+SDZ)) SDZ(+SDZ)=""
    51         Q
    52 INIT    F I1="SDENR","SDACT" S I2="^UTILITY("_$J_","""_I1_""","_SDIFN_")",@I2=0
    53         Q
     1SDCLAS ;ALB/TMP,MRY - Clinic Assignment List Extract ;12/23/92  11:42
     2 ;;5.3;Scheduling;**63,243,517**;Aug 13, 1993;Build 4
     3 ;SD/517 CORRECTED ALL $NEXT FUNCTIONAL COMMANDS
     4 S DIV="" D DIV^SDUTL I $T D CALST^SDDIV Q:Y<0
     5 S:'$D(DTIME) DTIME=300 I '$D(DT) D DT^SDUTL
     6 S SDIFN="",SDI=0,DIC="^SC(",DIC(0)="EFMQ",DIC("S")="I $P(^(0),U,3)=""C"",'$G(^(""OOS"")),$S(DIV="""":1,$P(^(0),U,15)=DIV:1,1:0)" D SELECT^SDCLAS0 K DIC Q:X["^"
     7 S Y=DT D DTS^SDUTL S SDTS=Y
     8OPT2 W !!,"Select 'As of' Date: ",SDTS," // " R X:DTIME Q:X["^"  I X']"" S SDTS=DT G OVR
     9 S %DT(0)=-DT,%DT="EPX" D ^%DT K %DT
     10 I Y'>0 W !,*7,"A date must be entered here to get a 'snapshot' of the clinic's enrollment as of",!,"  this date.  Date can not be in future." G OPT2
     11 S SDTS=+Y
     12OVR I SDSRT="C",SDSAV']"",SDIFN'="ALL",$S('$D(^SC(SDIFN,"I")):0,+^("I")=0:0,+^("I")>SDTS:0,+$P(^("I"),"^",2)'>SDTS&(+$P(^("I"),"^",2)'=0):0,1:1) W !,"Clinic ",$S(SDTS=DT:"is",1:"was")," inactive" W:SDTS<DT " on date selected" G END^SDCLAS1
     13 W !!,*7,"This needs to be printed at 132 columns"
     14 S PGM="START^SDCLAS",VAR="SDIFN^SDSRT^DIV^SDTS^SDSAV^SDFAST",VAL=SDIFN_"^"_SDSRT_"^"_DIV_"^"_SDTS_"^"_SDSAV_"^"_SDFAST D ZIS^DGUTQ Q:POP
     15START K ^UTILITY($J) S SDSTOP=$S(SDSRT="S":SDIFN,1:""),SD1="",U="^" U IO G:SDIFN="ALL"!(SDSRT="S")!(SDSAV]"") ALL
     16ONE S ONE=1 D INIT S SDAPPT=0 F  S SDAPPT=$O(^SC(SDIFN,"S",SDAPPT)) Q:'SDAPPT  D PT
     17 D:'SDFAST AEB^SDCLAS0 G ^SDCLAS1
     18ALL S ONE=0 I SDSAV']"" S SDIFN=0 F  S SDIFN=$O(^SC(SDIFN)) Q:'SDIFN  I $P(^(SDIFN,0),"^",3)="C" D APPT
     19 I SDSAV]"" D APART S SDIFN=0 F  S SDIFN=$O(SDZ(SDIFN)) Q:'SDIFN  I $D(^SC(SDIFN,0)),$P(^(0),"^",3)="C" D APPT
     20 G ^SDCLAS1
     21APPT D CHECK I 'POP K ^UTILITY($J,"PAT",SDIFN) D INIT S SDAPPT=0 F  S SDAPPT=$O(^SC(SDIFN,"S",SDAPPT)) D:SDAPPT PT I 'SDAPPT D:'SDFAST AEB^SDCLAS0 Q
     22 Q
     23PT S SD=0 F  S SD=$O(^SC(SDIFN,"S",SDAPPT,1,SD)) Q:'SD  Q:'$D(^(SD,0))  S DFN=+^(0) D PT1
     24 Q
     25PT1 I '$D(^UTILITY($J,"PAT",SDIFN,DFN)),$D(^DPT(DFN,0)),$D(^("S",SDAPPT,0)),$P(^(0),"^",2)=""!($P(^(0),"^",2)="I"),$S('$D(^DPT(DFN,.35)):1,'^(.35):1,1:0) D S,EXT^SDCLAS0
     26 Q
     27S S Y(0)=^DPT(DFN,0),SDACT=1,SDENR=0 D SET1
     28 S I=0 F  S I=$O(^DPT(DFN,"DE","B",SDIFN,I)) Q:'I  I $D(^DPT(DFN,"DE",I,0)) D EDENR Q:SDENR
     29 S ^UTILITY($J,"PAT",SDIFN,DFN)="" S:'$D(Y(1))!('SDENR) Y(1)="" I '$D(^UTILITY($J,"PAT"," ",DFN)) D MT S ^UTILITY($J,"PAT"," ",DFN)=$P(Y(0),"^",9)_"^"_SDELIG_"^"_SDZIP_"^"_$P(Y(0),"^",3)_U_SDMT
     30 Q
     31EDENR K Y(1) S I1=0 F  S I1=$O(^DPT(DFN,"DE",I,1,I1)) Q:'I1  S X=$P(^(I1,0),"^"),X(1)=$P(^(0),"^",3) Q:X>SDTS  S:'X(1)!(X(1)>SDTS) Y(1)=^(0),SDENR=1 Q:SDENR
     32 Q
     33SET1 S SDELIG=$S($D(^DPT(DFN,.36)):$P(^(.36),"^",1),1:""),SDELIG=$S($D(^DIC(8,+SDELIG,0)):SDELIG,1:""),SDELIG(1)=$S(SDELIG]"":$P(^(0),"^",5),1:""),SDZIP=$S($D(^DPT(DFN,.11)):$P(^(.11),"^",6),1:"")
     34 Q
     35MT ;
     36 S SDMT="*" Q:SDELIG(1)']""  I SDELIG(1)="N" S SDMT="N" Q
     37 S SDMT=$$LST^DGMTU(DFN) I SDMT']"" S SDMT=$S(SDELIG'=6:"A",1:"X") Q
     38 S:$P(SDMT,U,2)>SDTS SDMT=$$LST^DGMTU(DFN,SDTS)
     39 I $P(SDMT,U,4)="P" S SDMT=$$PA^DGMTUTL($P(SDMT,U)),SDMT=$S('$D(SDMT):"U",SDMT="MT":"C",SDMT="GMT":"G",1:"U")
     40 E  S SDMT=$P(SDMT,U,4)
     41 I SDMT="" S SDMT="X"
     42 I SDMT="P" S SDMT="C"
     43 I SDMT="R" S SDMT="U"
     44 I SDMT="N" S SDMT="A"
     45 D DOM^SDOPC4(DFN,SDTS_.9,.SDMT) I SDMT="X0" S SDMT="X"
     46 K SDMT1 Q
     47CHECK S POP=0 I SDSRT="S",SDSTOP'="ALL",$P(^SC(SDIFN,0),"^",7)'=SDSTOP S POP=1 Q
     48 I $S(DIV="":1,$P(^SC(SDIFN,0),"^",15)=DIV:1,1:0),$S('$D(^SC(SDIFN,"I")):1,+^("I")=0:1,+^("I")>DT:1,+$P(^("I"),"^",2)'>DT&(+$P(^("I"),"^",2)'=0):1,1:0) Q
     49 S POP=1 Q
     50APART S SDZ="" F I=1:1 Q:$P(SDSAV,",",I)']""  S SDZ=$P(SDSAV,",",I) D:SDZ["--" SPLIT^SDCLAS0 I SDZ'["--" S:'$D(SDZ(+SDZ)) SDZ(+SDZ)=""
     51 Q
     52INIT F I1="SDENR","SDACT" S I2="^UTILITY("_$J_","""_I1_""","_SDIFN_")",@I2=0
     53 Q

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDCLAV0.m

    r613 r623  
    1 SDCLAV0 ;ALB/LDB - OUTPUT PATTERNS (cont.) ; 05 Mar 99 11:31 AM
    2         ;;5.3;Scheduling;**184,439,490,517,529**;Aug 13, 1993;Build 3
    3         ;SD/517 CHANGED FOR LOOPS
    4         I 'VAUTC S SDC=0 F  S SDC=$O(VAUTC(SDC)) Q:'SDC  S SDV=VAUTC(SDC) D:VAUTD!($D(VAUTD(+$P(^SC(SDC,0),"^",15))))!('$P(^(0),"^",15)&$D(VAUTD($P(^DG(43,1,"GL"),"^",3)))) S1
    5         I VAUTC S SDC=0 F  S SDC=$O(^SC(SDC)) Q:'SDC  I $P(^(SDC,0),"^",3)="C" D:VAUTD!($D(VAUTD(+$P(^(0),"^",15))))!('$P(^(0),"^",15)&$D(VAUTD($P(^DG(43,1,"GL"),"^",3)))) S1
    6         I $D(^UTILITY($J,"SDNMS")) D S2^SDCLAV1
    7         ;following line commented off per SD*529
    8         ;S DGTCH="CLINIC AVAILABILITY REPORT^CLINIC^PAGE#" D:$E(IOST,1,2)="P-" TP^DGUTL K SDBD,SDCI,SDED D END^SDCLAV Q
    9         D END^SDCLAV Q
    10 S1      S SD=^SC(SDC,0),D=$S($P(SD,"^",15):$P(SD,"^",15),1:$P(^DG(43,1,"GL"),"^",3)),SD5=0,SDNM=$P(SD,"^")
    11         S $P(^UTILITY($J,"SDNMS",D,SDNM),"^",3)=SDC
    12         Q
    13 NM      ;called by SDCLAV1 - SD/517 CHANGED FOR LOOP
    14         S SDAP1=0 F  S SDAP1=$O(^SC(SDC,"S",SDAP,1,SDAP1)) Q:'SDAP1  D NM1
    15         K M1,SDN1,SDN2,SDN3,SDC3,SDAP1  ; SD*5.3*439 added Kill of local vars
    16         Q
    17 NM1     I '$D(^SC(SDC,"S",SDAP,1,SDAP1,0)) N POP S POP=0 D CHECK,KILL Q  ;added SD/517
    18         S SDN1=+^SC(SDC,"S",SDAP,1,SDAP1,0),M1=$P(^(0),"^",2),SDC3=$P(^(0),"^",9),SDN2=$P(^DPT(+SDN1,0),"^"),SDN3=$P(^(0),"^",9),SDN3=$S(SDN3="":"UNKNOWN",1:SDN3) I $D(SDCI) D NM2 Q
    19         ; SD*5.3*439 added quit if clinic in "S" node not = to selected clinic
    20         I '$D(SDCI),$D(^DPT(SDN1,"S",SDAP,0)),$P(^(0),"^",2)'["C",$P(^(0),"^",2)'="N",$P(^(0),"^",2)'="NA" Q:$P(^(0),U,1)'=SDC  D NM2 Q
    21         Q
    22         ;SD*5.3*490 do not display appts prior to clinic start date
    23 NM2     Q:$P(SDAP,".",1)<$O(^SC(SDC,"T",0))  ;SD*5.3*490
    24         S:$D(^DPT(SDN1,"S",SDAP,0)) ^UTILITY($J,"SDNMS",D,SDV,SDAP,SDN2,SDN3)=M1_$S(($P(^DPT(SDN1,"S",SDAP,0),"^",2)["C"):"^*",SDC3="C":"^*",($P(^(0),"^",2)="N"):"^**",($P(^(0),"^",2)="NA"):"^**",1:"")
    25         S:$D(^DPT(SDN1,"S",SDAP,0)) $P(^UTILITY($J,"SDNMS",D,SDV,SDAP,SDN2,SDN3),"^",3)=$S($P(^DPT(SDN1,"S",SDAP,0),"^",7)=4:"***",1:"")
    26         Q
    27         ;
    28 CHECK   ;Added SD/517
    29         N SDIEN,NODE,NODE0,HDFN,HDNAM,HDSN,POP
    30         S SDIEN=0,NODE="",HDAP1=SDAP1
    31         F  S SDIEN=$O(^SCE("B",SDAP,SDIEN)) Q:'SDIEN  D
    32         .S NODE=^SCE(SDIEN,0)
    33         .Q:$P(NODE,U,4)'=SDC
    34         .S HDFN=$P(NODE,U,2),HDNAM=$P(^DPT(HDFN,0),U),HDSN=$P(^(0),U,9)
    35         .Q:$D(^UTILITY($J,"SDNMS",D,SDV,SDAP,HDNAM,HDSN))
    36         .S POP=0 D CHECK1 Q:POP
    37         .S SDN1=$P(NODE,U,2),SDN2=$P(^DPT(SDN1,0),U),SDN3=$P(^DPT(SDN1,0),U,9),M1="",SDC3=""
    38         .D NM2
    39         Q
    40         ;
    41 CHECK1  ;Added SD/517
    42         S HDAP1=$O(^SC(SDC,"S",SDAP,1,HDAP1)) Q:'HDAP1
    43         Q:'$D(^SC(SDC,"S",SDAP,1,HDAP1,0))  S NODE0=^(0)
    44         I $P(NODE0,U,1)=HDFN S POP=1 Q
    45         Q
    46         ;
    47 KILL    K SDIEN,NODE,NODE0,POP,HDFN,HDNAM,HDSN,HDAP1  ;added SD/517
    48         Q
     1SDCLAV0 ;ALB/LDB - OUTPUT PATTERNS (cont.) ; 05 Mar 99 11:31 AM
     2 ;;5.3;Scheduling;**184,439,490,517**;Aug 13, 1993;Build 4
     3 ;SD/517 CHANGED FOR LOOPS
     4 I 'VAUTC S SDC=0 F  S SDC=$O(VAUTC(SDC)) Q:'SDC  S SDV=VAUTC(SDC) D:VAUTD!($D(VAUTD(+$P(^SC(SDC,0),"^",15))))!('$P(^(0),"^",15)&$D(VAUTD($P(^DG(43,1,"GL"),"^",3)))) S1
     5 I VAUTC S SDC=0 F  S SDC=$O(^SC(SDC)) Q:'SDC  I $P(^(SDC,0),"^",3)="C" D:VAUTD!($D(VAUTD(+$P(^(0),"^",15))))!('$P(^(0),"^",15)&$D(VAUTD($P(^DG(43,1,"GL"),"^",3)))) S1
     6 I $D(^UTILITY($J,"SDNMS")) D S2^SDCLAV1
     7 S DGTCH="CLINIC AVAILABILITY REPORT^CLINIC^PAGE#" D:$E(IOST,1,2)="P-" TP^DGUTL K SDBD,SDCI,SDED D END^SDCLAV Q
     8S1 S SD=^SC(SDC,0),D=$S($P(SD,"^",15):$P(SD,"^",15),1:$P(^DG(43,1,"GL"),"^",3)),SD5=0,SDNM=$P(SD,"^")
     9 S $P(^UTILITY($J,"SDNMS",D,SDNM),"^",3)=SDC
     10 Q
     11NM ;called by SDCLAV1 - SD/517 CHANGED FOR LOOP
     12 S SDAP1=0 F  S SDAP1=$O(^SC(SDC,"S",SDAP,1,SDAP1)) Q:'SDAP1  D NM1
     13 K M1,SDN1,SDN2,SDN3,SDC3,SDAP1  ; SD*5.3*439 added Kill of local vars
     14 Q
     15NM1 I '$D(^SC(SDC,"S",SDAP,1,SDAP1,0)) N POP S POP=0 D CHECK,KILL Q  ;added SD/517
     16 S SDN1=+^SC(SDC,"S",SDAP,1,SDAP1,0),M1=$P(^(0),"^",2),SDC3=$P(^(0),"^",9),SDN2=$P(^DPT(+SDN1,0),"^"),SDN3=$P(^(0),"^",9),SDN3=$S(SDN3="":"UNKNOWN",1:SDN3) I $D(SDCI) D NM2 Q
     17 ; SD*5.3*439 added quit if clinic in "S" node not = to selected clinic
     18 I '$D(SDCI),$D(^DPT(SDN1,"S",SDAP,0)),$P(^(0),"^",2)'["C",$P(^(0),"^",2)'="N",$P(^(0),"^",2)'="NA" Q:$P(^(0),U,1)'=SDC  D NM2 Q
     19 Q
     20 ;SD*5.3*490 do not display appts prior to clinic start date
     21NM2 Q:$P(SDAP,".",1)<$O(^SC(SDC,"T",0))  ;SD*5.3*490
     22 S:$D(^DPT(SDN1,"S",SDAP,0)) ^UTILITY($J,"SDNMS",D,SDV,SDAP,SDN2,SDN3)=M1_$S(($P(^DPT(SDN1,"S",SDAP,0),"^",2)["C"):"^*",SDC3="C":"^*",($P(^(0),"^",2)="N"):"^**",($P(^(0),"^",2)="NA"):"^**",1:"")
     23 S:$D(^DPT(SDN1,"S",SDAP,0)) $P(^UTILITY($J,"SDNMS",D,SDV,SDAP,SDN2,SDN3),"^",3)=$S($P(^DPT(SDN1,"S",SDAP,0),"^",7)=4:"***",1:"")
     24 Q
     25 ;
     26CHECK ;Added SD/517
     27 N SDIEN,NODE,NODE0,HDFN,HDNAM,HDSN,POP
     28 S SDIEN=0,NODE="",HDAP1=SDAP1
     29 F  S SDIEN=$O(^SCE("B",SDAP,SDIEN)) Q:'SDIEN  D
     30 .S NODE=^SCE(SDIEN,0)
     31 .Q:$P(NODE,U,4)'=SDC
     32 .S HDFN=$P(NODE,U,2),HDNAM=$P(^DPT(HDFN,0),U),HDSN=$P(^(0),U,9)
     33 .Q:$D(^UTILITY($J,"SDNMS",D,SDV,SDAP,HDNAM,HDSN))
     34 .S POP=0 D CHECK1 Q:POP
     35 .S SDN1=$P(NODE,U,2),SDN2=$P(^DPT(SDN1,0),U),SDN3=$P(^DPT(SDN1,0),U,9),M1="",SDC3=""
     36 .D NM2
     37 Q
     38 ;
     39CHECK1 ;Added SD/517
     40 S HDAP1=$O(^SC(SDC,"S",SDAP,1,HDAP1)) Q:'HDAP1
     41 Q:'$D(^SC(SDC,"S",SDAP,1,HDAP1,0))  S NODE0=^(0)
     42 I $P(NODE0,U,1)=HDFN S POP=1 Q
     43 Q
     44 ;
     45KILL K SDIEN,NODE,NODE0,POP,HDFN,HDNAM,HDSN,HDAP1  ;added SD/517
     46 Q

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDCWL2.m

    r613 r623  
    1 SDCWL2  ;ALB/MLI - CONTINUATION OF CLINIC WORKLOAD REPORTS ; 07 Mar 99  6:41 PM
    2         ;;5.3;Scheduling;**140,132,171,184,529**;Aug 13, 1993;Build 3
    3 PRO     S SDAS=$S($P(^SC(I,"S",J,1,K,0),U,9)="C":"C",1:$P(^DPT(DFN,"S",J,0),U,2)) S SDP=$P(^DPT(DFN,"S",J,0),U,7)
    4 PRO1    S SDP=$P(^DPT(DFN,"S",J,0),U,7) S:SDS="C" ^(SDN)=$S($D(^TMP($J,"CL",'$D(SDFL),SDN)):^(SDN),1:0)
    5         I SDS="S" S:SDF1 ^(SDSC)=$S($D(^TMP($J,"SC",'$D(SDFL),SDSC)):^(SDSC),1:0) I SDF2 S ^(SDCR)=$S($D(^TMP($J,"SC",'$D(SDFL),SDCR)):^(SDCR),1:0)
    6         S $P(^TMP($J,"CL",'$D(SDFL),SDN),"^")=1 I SDS="S" S:SDF1 $P(^TMP($J,"SC",'$D(SDFL),SDSC),"^")=1 I SDF2 S $P(^TMP($J,"SC",'$D(SDFL),SDCR),"^")=1
    7         I SDAS'["C",SDAS'="N",SDAS'="NA" S:SDS="C" $P(^(SDN),U,2)=$P(^TMP($J,"CL",'$D(SDFL),SDN),U,2)+1 I SDS="S" S:SDF1 $P(^(SDSC),U,2)=$P(^TMP($J,"SC",'$D(SDFL),SDSC),U,2)+1 I SDF2 S $P(^(SDCR),U,2)=$P(^TMP($J,"SC",'$D(SDFL),SDCR),U,2)+1
    8         I $D(SDFL) S:SDS="C" ^(SDN)=$S($D(^TMP($J,"CL",1,SDN)):^(SDN),1:0) I SDS="S" S:SDF1 ^(SDSC)=$S($D(^TMP($J,"SC",1,SDSC)):^(SDSC),1:0) S:SDF2 ^(SDCR)=$S($D(^TMP($J,"SC",1,SDCR)):^(SDCR),1:0)
    9         Q:$D(SDFL)!(SDRT="B")  S SDAPT=$S(SDF="D":J\1,1:J\100) S:'$D(^TMP($J,1,SDN,SDAPT)) (^(SDAPT,"CA"),^("NS"),^("IN"),^("OB"),^("UN"),^("SD"))=0
    10         S TIME=$E($P(J,".",2)_"0000",1,4),TIME=$E(TIME,1,2)_":"_$E(TIME,3,4)
    11         S:SDNAM SDPN=$E($P(^DPT(DFN,0),U),1,20),SDSSN=$S($P(^(0),U,9)]"":$P(^(0),U,9),1:0),^TMP($J,1,SDN,SDAPT,"NM",SDPN,SDSSN,TIME,$S(SDAS]"":SDAS,SDOB:"OB",SDP=1:"S",SDP=3:"S",SDP=4:"U",1:" "))=""  ;added SDP=1 SD*529
    12         K TIME I SDAS["C" S ^("CA")=^TMP($J,1,SDN,SDAPT,"CA")+1 Q
    13         I SDAS="N"!(SDAS="NA") S ^("NS")=^TMP($J,1,SDN,SDAPT,"NS")+1 Q
    14         I SDAS["I" S ^("IN")=^TMP($J,1,SDN,SDAPT,"IN")+1 Q
    15         I SDOB S ^("OB")=^TMP($J,1,SDN,SDAPT,"OB")+1 Q
    16         I SDP=4 S ^("UN")=^TMP($J,1,SDN,SDAPT,"UN")+1 Q
    17         S ^("SD")=^TMP($J,1,SDN,SDAPT,"SD")+1 Q
    18 PREV    S SDBD=SDBD+.1,SDED=SDED-.9,SDBO=$TR($$FMTE^XLFDT(SDBD,"2FD")," ","0"),SDEO=$TR($$FMTE^XLFDT(SDED,"2FD")," ","0"),I=0,SDSUB=$S(SDS="C":"CL",1:"SC") D COMPHEAD
    19         F I1=0:0 S I=$O(^TMP($J,SDSUB,1,I)) Q:I=""  S SDCUR=+$P(^(I),"^",2),SDOLD=+$S($D(^TMP($J,SDSUB,0,I)):$P(^(I),"^",2),1:0) D:($Y>(IOSL-8)) EOP,COMPHEAD D COMPARE
    20         D EOP Q
    21 COMPHEAD        S SDPG=SDPG+1 W @IOF,!?29,"CLINIC WORKLOAD REPORT",?71,"PAGE: ",$J(SDPG,3),!?22,"COMPARISON OF VISITS TO PREVIOUS YEAR",!?20,"FOR PERIOD COVERING:  ",SDB1,"-",SDE1,!?26,"REPORT RUN ON:  ",SDNOW,!! K Y S $P(Y,"_",81)="" W Y D BLANK
    22         W !,"|",?25,"|",?29,"# OF VISITS",?43,"|",?47,"# OF VISITS",?61,"|",?64,"NET",?70,"|",?74,"%",?79,"|",!,"|",?7,$S(SDS="C":"Clinic",1:"Stop Code")," Name",?25,"|",SDB,"-",SDE,"|",SDBO,"-",SDEO,"| CHANGE | CHANGE |" D EOP,EOP,BLANK Q
    23 COMPARE W !,"|",$S(SDS="C":$E(I,1,24),1:$J(I,15)),?25,"|",?31,$J(SDCUR,7),?43,"|",?49,$J(SDOLD,7),?61,"|" S X=SDCUR-SDOLD W $J($S(X>0:"+"_X,2:X),7,2),?70,"|",$S(SDOLD=0:"    N/A",1:$J(X*100/SDOLD,7,2))," |" Q
    24 EOP     W !,"|" K Y S $P(Y,"_",25)="" W Y,"|",$E(Y,1,17),"|",$E(Y,1,17),"|",$E(Y,1,8),"|",$E(Y,1,8),"|" Q
    25 BLANK   W !,"|",?25,"|",?43,"|",?61,"|",?70,"|",?79,"|" Q
    26 ADDON   I 'SDALL&'$D(SDCL(SDSC)) Q
    27         S J=SDOE,I=+SDOE0
    28         S DIV=$S($P(SDOE0,"^",11)]"":$P(SDOE0,"^",11),1:$O(^DG(40.8,0))),DFN=+$P(SDOE0,U,2) Q:'VAUTD&'$D(VAUTD(DIV))
    29         S $P(^TMP($J,"SC",'$D(SDFL),SDSC),"^")=1,$P(^(SDSC),"^",2)=$P(^(SDSC),"^",2)+1 Q:(SDRT="B")  S ^("{")=$S($D(^(SDSC,"{")):^("{")+1,1:1),SDAPT=$S(SDF="D":I\1,1:I\100)
    30         Q:$D(SDFL)  S ^(SDAPT)=$S($D(^TMP($J,"SC",SDSC,"{",SDAPT)):^(SDAPT)+1,1:1)
    31         Q:'SDNAM  S SDNM=$P(^DPT(DFN,0),U),SDSSN=$S($P(^(0),U,9)]"":$P(^(0),U,9),1:0),^TMP($J,"SC",SDSC,"{",SDAPT,SDNM,SDSSN,I,J)="" Q
     1SDCWL2 ;ALB/MLI - CONTINUATION OF CLINIC WORKLOAD REPORTS ; 07 Mar 99  6:41 PM
     2 ;;5.3;Scheduling;**140,132,171,184**;Aug 13, 1993
     3PRO S SDAS=$S($P(^SC(I,"S",J,1,K,0),U,9)="C":"C",1:$P(^DPT(DFN,"S",J,0),U,2)) S SDP=$P(^DPT(DFN,"S",J,0),U,7)
     4PRO1 S SDP=$P(^DPT(DFN,"S",J,0),U,7) S:SDS="C" ^(SDN)=$S($D(^TMP($J,"CL",'$D(SDFL),SDN)):^(SDN),1:0)
     5 I SDS="S" S:SDF1 ^(SDSC)=$S($D(^TMP($J,"SC",'$D(SDFL),SDSC)):^(SDSC),1:0) I SDF2 S ^(SDCR)=$S($D(^TMP($J,"SC",'$D(SDFL),SDCR)):^(SDCR),1:0)
     6 S $P(^TMP($J,"CL",'$D(SDFL),SDN),"^")=1 I SDS="S" S:SDF1 $P(^TMP($J,"SC",'$D(SDFL),SDSC),"^")=1 I SDF2 S $P(^TMP($J,"SC",'$D(SDFL),SDCR),"^")=1
     7 I SDAS'["C",SDAS'="N",SDAS'="NA" S:SDS="C" $P(^(SDN),U,2)=$P(^TMP($J,"CL",'$D(SDFL),SDN),U,2)+1 I SDS="S" S:SDF1 $P(^(SDSC),U,2)=$P(^TMP($J,"SC",'$D(SDFL),SDSC),U,2)+1 I SDF2 S $P(^(SDCR),U,2)=$P(^TMP($J,"SC",'$D(SDFL),SDCR),U,2)+1
     8 I $D(SDFL) S:SDS="C" ^(SDN)=$S($D(^TMP($J,"CL",1,SDN)):^(SDN),1:0) I SDS="S" S:SDF1 ^(SDSC)=$S($D(^TMP($J,"SC",1,SDSC)):^(SDSC),1:0) S:SDF2 ^(SDCR)=$S($D(^TMP($J,"SC",1,SDCR)):^(SDCR),1:0)
     9 Q:$D(SDFL)!(SDRT="B")  S SDAPT=$S(SDF="D":J\1,1:J\100) S:'$D(^TMP($J,1,SDN,SDAPT)) (^(SDAPT,"CA"),^("NS"),^("IN"),^("OB"),^("UN"),^("SD"))=0
     10 S TIME=$E($P(J,".",2)_"0000",1,4),TIME=$E(TIME,1,2)_":"_$E(TIME,3,4)
     11 S:SDNAM SDPN=$E($P(^DPT(DFN,0),U),1,20),SDSSN=$S($P(^(0),U,9)]"":$P(^(0),U,9),1:0),^TMP($J,1,SDN,SDAPT,"NM",SDPN,SDSSN,TIME,$S(SDAS]"":SDAS,SDOB:"OB",SDP=3:"S",SDP=4:"U",1:" "))=""
     12 K TIME I SDAS["C" S ^("CA")=^TMP($J,1,SDN,SDAPT,"CA")+1 Q
     13 I SDAS="N"!(SDAS="NA") S ^("NS")=^TMP($J,1,SDN,SDAPT,"NS")+1 Q
     14 I SDAS["I" S ^("IN")=^TMP($J,1,SDN,SDAPT,"IN")+1 Q
     15 I SDOB S ^("OB")=^TMP($J,1,SDN,SDAPT,"OB")+1 Q
     16 I SDP=4 S ^("UN")=^TMP($J,1,SDN,SDAPT,"UN")+1 Q
     17 S ^("SD")=^TMP($J,1,SDN,SDAPT,"SD")+1 Q
     18PREV S SDBD=SDBD+.1,SDED=SDED-.9,SDBO=$TR($$FMTE^XLFDT(SDBD,"2FD")," ","0"),SDEO=$TR($$FMTE^XLFDT(SDED,"2FD")," ","0"),I=0,SDSUB=$S(SDS="C":"CL",1:"SC") D COMPHEAD
     19 F I1=0:0 S I=$O(^TMP($J,SDSUB,1,I)) Q:I=""  S SDCUR=+$P(^(I),"^",2),SDOLD=+$S($D(^TMP($J,SDSUB,0,I)):$P(^(I),"^",2),1:0) D:($Y>(IOSL-8)) EOP,COMPHEAD D COMPARE
     20 D EOP Q
     21COMPHEAD S SDPG=SDPG+1 W @IOF,!?29,"CLINIC WORKLOAD REPORT",?71,"PAGE: ",$J(SDPG,3),!?22,"COMPARISON OF VISITS TO PREVIOUS YEAR",!?20,"FOR PERIOD COVERING:  ",SDB1,"-",SDE1,!?26,"REPORT RUN ON:  ",SDNOW,!! K Y S $P(Y,"_",81)="" W Y D BLANK
     22 W !,"|",?25,"|",?29,"# OF VISITS",?43,"|",?47,"# OF VISITS",?61,"|",?64,"NET",?70,"|",?74,"%",?79,"|",!,"|",?7,$S(SDS="C":"Clinic",1:"Stop Code")," Name",?25,"|",SDB,"-",SDE,"|",SDBO,"-",SDEO,"| CHANGE | CHANGE |" D EOP,EOP,BLANK Q
     23COMPARE W !,"|",$S(SDS="C":$E(I,1,24),1:$J(I,15)),?25,"|",?31,$J(SDCUR,7),?43,"|",?49,$J(SDOLD,7),?61,"|" S X=SDCUR-SDOLD W $J($S(X>0:"+"_X,2:X),7,2),?70,"|",$S(SDOLD=0:"    N/A",1:$J(X*100/SDOLD,7,2))," |" Q
     24EOP W !,"|" K Y S $P(Y,"_",25)="" W Y,"|",$E(Y,1,17),"|",$E(Y,1,17),"|",$E(Y,1,8),"|",$E(Y,1,8),"|" Q
     25BLANK W !,"|",?25,"|",?43,"|",?61,"|",?70,"|",?79,"|" Q
     26ADDON I 'SDALL&'$D(SDCL(SDSC)) Q
     27 S J=SDOE,I=+SDOE0
     28 S DIV=$S($P(SDOE0,"^",11)]"":$P(SDOE0,"^",11),1:$O(^DG(40.8,0))),DFN=+$P(SDOE0,U,2) Q:'VAUTD&'$D(VAUTD(DIV))
     29 S $P(^TMP($J,"SC",'$D(SDFL),SDSC),"^")=1,$P(^(SDSC),"^",2)=$P(^(SDSC),"^",2)+1 Q:(SDRT="B")  S ^("{")=$S($D(^(SDSC,"{")):^("{")+1,1:1),SDAPT=$S(SDF="D":I\1,1:I\100)
     30 Q:$D(SDFL)  S ^(SDAPT)=$S($D(^TMP($J,"SC",SDSC,"{",SDAPT)):^(SDAPT)+1,1:1)
     31 Q:'SDNAM  S SDNM=$P(^DPT(DFN,0),U),SDSSN=$S($P(^(0),U,9)]"":$P(^(0),U,9),1:0),^TMP($J,"SC",SDSC,"{",SDAPT,SDNM,SDSSN,I,J)="" Q

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDD0.m

    r613 r623  
    1 SDD0    ;SF/GFT,ALB/BOK,JSH,LDB - REMAP A CLINIC ; 26 JAN 84  3:00 pm
    2         ;;5.3;Scheduling;**167,401,529**;Aug 13, 1993;Build 3
    3 SETX    ;
    4         N SDDIV
    5         S SDDIV=$P($G(SD0),"^",15) Q:SDDIV=""
    6         I '$D(VAUTD(SDDIV)),VAUTD=0 Q
    7         Q:'$D(^SC(SC,"SL"))  S SDSL=^("SL"),SL=+^("SL"),X=$P(SDSL,U,3),STARTDAY=$S($L(X):X,1:8),X=$P(SDSL,U,6),HSI=$S('X:4,X<3:8/X,1:2),SI=$S(X:X,1:4),SDSI=SI
    8         S:SI=1 SI=4 S:SI=2 SI=4 S SDSOH=$S($P(SDSL,U,8)']"":0,1:1)
    9         K SDIN,SDRE,SDRE1 N SDNODE I $D(^SC(SC,"I")) S SDIN=+^("I"),SDRE=+$P(^("I"),"^",2),Y=SDRE D DTS^SDUTL S SDRE1=Y
    10         F DATE=$$FMADD^XLFDT(SDBD,-1):0 S X1=DATE,X2=1 N X D C^%DTC S DATE=X S SDNODE=$D(^SC(SC,"ST",DATE)) Q:DATE'>0!(DATE>SDED)  I $S('$D(SDIN):1,'SDIN:1,SDIN>DATE:1,SDRE'>DATE&(SDRE):1,1:0) K SM,SDHOL D CHECK  ;changed 1st part of For loop SD*529
    11         Q
    12 CHECK   S X=DATE D DW^%DTC S DAY=$P("SUN^MON^TUES^WEDNES^THURS^FRI^SATUR",U,Y+1),DOW=Y
    13         D APPT I $D(^SC(SC,"ST",DATE,1)),^(1)'[$E(DAY,1,2)&(^(1)["]") S MSG="Bogus clinic day"_$S(SDAPPT:"- Appts!",1:"") D PRNT
    14         I $D(^SC(SC,"ST",DATE,1)),^(1)["CANCEL"!($E(^(1),$F(^(1),"["),999)?."X") S MSG="Cancelled" D PRNT Q
    15         I $D(^HOLIDAY(DATE,0)),'SDSOH S SDHOL=1,X=$P(^(0),U,2) G HOLIDAY:'SDAPPT,Z:SDAPPT
    16         K ^SC(SC,"ST",DATE) S SS=+$O(^SC(SC,"T"_DOW,DATE)),SB=STARTDAY-1/100,STR="{}&%?#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz"
    17         I $D(^SC(SC,"OST",DATE,1)),^(1)]"" S (X,DR)=DATE D DOW^SDM0 S DOW=Y,SM=^SC(SC,"OST",DATE,1),SS=0 G:'SDAPPT OVR G I
    18         G Z:'$D(^SC(SC,"T"_DOW,SS,1)) I ^(1)="" S MSG="no master pattern for this day" D:SDNODE PRNT Q
    19         S DH=^(1),X=DATE G FIX ;NAKED REFERENCE ^SC(IFN,"T"_DOW,DATE,1)
    20 HOLIDAY S ^SC(SC,"ST",DATE,1)="   "_$E(DATE,6,7)_"    "_X,^(0)=DATE
    21 Z       S MSG=$S($D(SDHOL)&SDAPPT:"- Appts!",'SDSOH&$D(SDHOL):"- Inserted",1:"") I MSG]"" S MSG=X_MSG D PRNT
    22         Q
    23 END     K %,%DT,DATE,DAY,DH,DOW,DR,DR1,HSI,I,P,POP,S,SB,SC,SDAPPT,SDAPPT1,SDBD,SDNM,SDED,SDHOL,SD0,SDIN,SDRE,SDRE1,SDSAVX,SDSL,SDSOH,SI,SM,SS,SD,SCI,SCC,ST,STARTDAY,STR,X,MSG,Y,YP,PG,DGVAR,DGPGM,VAUTD,VAUTC,SDU,BEGDATE,ENDDATE D CLOSE^DGUTQ Q
    24 FIX     ;DH=PATTERN  X=DATE
    25         D SM G:'SDAPPT OVR
    26 I       S I=DR#1-SB*100,I=I#1*SI\.6+(I\1*SI)*2,S=$E(SM,I,999),SM=$E(SM,1,I-1)
    27         I $D(^SC(SC,"S",DR,"MES")) D CAN S X=SDSAVX K SDSAVX S DR=+$O(^SC(SC,"S",DR)) G:DR\1=X I G OVR
    28         F Y=0:0 S Y=$O(^SC(SC,"S",DR,1,Y)) Q:Y'>0  I $P(^(Y,0),"^",9)'["C" S SDSL=$P(^(0),U,2)/SL*(SL\(60/SDSI))*HSI-HSI F I=0:HSI:SDSL S ST=$E(S,I+2) S:ST="" ST=" " S S=$E(S,1,I+2-1)_$E(STR,$F(STR,ST)-2)_$E(S,I+3,999)
    29         S SM=SM_S,DR=$O(^SC(SC,"S",DR)) I DR\1=X G I
    30 OVR     I $L(SM)>SM S ^SC(SC,"ST",X,0)=X,^(1)=SM S:SS'>0 ^(9)=SC
    31         G Z
    32 SM      S SM=$P("SU^MO^TU^WE^TH^FR^SA",U,DOW+1)_" "_$E(X,6,7)_$J("",SI+SI-6)_DH_$J("",64-$L(DH)) Q
    33 APPT    S DR=+$O(^SC(SC,"S",DATE)),SDAPPT=0 I DR>(DATE_.9) S DR=DATE Q
    34         F DR1=DATE:0 S DR1=$O(^SC(SC,"S",DR1)) Q:DR1'>0!(DR1>(DATE+1))!(SDAPPT)  S:$D(^(DR1,"MES")) SDAPPT=1 F SDAPPT1=0:0 S SDAPPT1=$O(^SC(SC,"S",DR1,1,SDAPPT1)) Q:SDAPPT1'>0  I $D(^(SDAPPT1,0)) S SDAPPT=$S($P(^(0),"^",9)="C":0,1:1)
    35         Q
    36 CAN     S SDSAVX=X Q:'$D(^SC(SC,"SDCAN",DR,0))  S X=$E($P(DR,".",2)_"0000",1,4),I=SM_S D TT S ST=%,X=$P(^SC(SC,"SDCAN",DR,0),"^",2) D TT S I=I_$J("",%-$L(I)),Y=""
    37         F X=0:2:% S S=$E(I,X+SI+SI),P=$S(X<ST:S_$E(I,X+1+SI+SI),X=%:$S(Y="[":Y,1:S)_$E(I,X+1+SI+SI),1:$S(Y="["&(X=ST):"]",1:"X")_"X"),Y=$S(S="]":"",S="[":S,1:Y),I=$E(I,1,X-1+SI+SI)_P_$E(I,X+2+SI+SI,999)
    38         S SM=I Q
    39 TT      S %=$E(X,3,4),%=X\100-STARTDAY*SI+(%*SI\60)*2 Q
    40 PRNT    U IO S YP=YP+1 D:YP>(IOSL-4) ESC^SDD W !,$E(SDNM,1,25),?27,$E(DAY,1,3)_" " S Y=DATE D DT^DIO2 W ?45,MSG Q
    41 ESC     S SDU=0 I $E(IOST,1,2)="C-" W *7 R ESC:DTIME S:U=ESC SDU=1
     1SDD0 ;SF/GFT,ALB/BOK,JSH,LDB - REMAP A CLINIC ; 26 JAN 84  3:00 pm
     2 ;;5.3;Scheduling;**167,401**;Aug 13, 1993
     3SETX ;
     4 N SDDIV
     5 S SDDIV=$P($G(SD0),"^",15) Q:SDDIV=""
     6 I '$D(VAUTD(SDDIV)),VAUTD=0 Q
     7 Q:'$D(^SC(SC,"SL"))  S SDSL=^("SL"),SL=+^("SL"),X=$P(SDSL,U,3),STARTDAY=$S($L(X):X,1:8),X=$P(SDSL,U,6),HSI=$S('X:4,X<3:8/X,1:2),SI=$S(X:X,1:4),SDSI=SI
     8 S:SI=1 SI=4 S:SI=2 SI=4 S SDSOH=$S($P(SDSL,U,8)']"":0,1:1)
     9 K SDIN,SDRE,SDRE1 N SDNODE I $D(^SC(SC,"I")) S SDIN=+^("I"),SDRE=+$P(^("I"),"^",2),Y=SDRE D DTS^SDUTL S SDRE1=Y
     10 F DATE=SDBD-1:0 S X1=DATE,X2=1 N X D C^%DTC S DATE=X S SDNODE=$D(^SC(SC,"ST",DATE)) Q:DATE'>0!(DATE>SDED)  I $S('$D(SDIN):1,'SDIN:1,SDIN>DATE:1,SDRE'>DATE&(SDRE):1,1:0) K SM,SDHOL D CHECK
     11 Q
     12CHECK S X=DATE D DW^%DTC S DAY=$P("SUN^MON^TUES^WEDNES^THURS^FRI^SATUR",U,Y+1),DOW=Y
     13 D APPT I $D(^SC(SC,"ST",DATE,1)),^(1)'[$E(DAY,1,2)&(^(1)["]") S MSG="Bogus clinic day"_$S(SDAPPT:"- Appts!",1:"") D PRNT
     14 I $D(^SC(SC,"ST",DATE,1)),^(1)["CANCEL"!($E(^(1),$F(^(1),"["),999)?."X") S MSG="Cancelled" D PRNT Q
     15 I $D(^HOLIDAY(DATE,0)),'SDSOH S SDHOL=1,X=$P(^(0),U,2) G HOLIDAY:'SDAPPT,Z:SDAPPT
     16 K ^SC(SC,"ST",DATE) S SS=+$O(^SC(SC,"T"_DOW,DATE)),SB=STARTDAY-1/100,STR="{}&%?#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz"
     17 I $D(^SC(SC,"OST",DATE,1)),^(1)]"" S (X,DR)=DATE D DOW^SDM0 S DOW=Y,SM=^SC(SC,"OST",DATE,1),SS=0 G:'SDAPPT OVR G I
     18 G Z:'$D(^SC(SC,"T"_DOW,SS,1)) I ^(1)="" S MSG="no master pattern for this day" D:SDNODE PRNT Q
     19 S DH=^(1),X=DATE G FIX ;NAKED REFERENCE ^SC(IFN,"T"_DOW,DATE,1)
     20HOLIDAY S ^SC(SC,"ST",DATE,1)="   "_$E(DATE,6,7)_"    "_X,^(0)=DATE
     21Z S MSG=$S($D(SDHOL)&SDAPPT:"- Appts!",'SDSOH&$D(SDHOL):"- Inserted",1:"") I MSG]"" S MSG=X_MSG D PRNT
     22 Q
     23END K %,%DT,DATE,DAY,DH,DOW,DR,DR1,HSI,I,P,POP,S,SB,SC,SDAPPT,SDAPPT1,SDBD,SDNM,SDED,SDHOL,SD0,SDIN,SDRE,SDRE1,SDSAVX,SDSL,SDSOH,SI,SM,SS,SD,SCI,SCC,ST,STARTDAY,STR,X,MSG,Y,YP,PG,DGVAR,DGPGM,VAUTD,VAUTC,SDU,BEGDATE,ENDDATE D CLOSE^DGUTQ Q
     24FIX ;DH=PATTERN  X=DATE
     25 D SM G:'SDAPPT OVR
     26I S I=DR#1-SB*100,I=I#1*SI\.6+(I\1*SI)*2,S=$E(SM,I,999),SM=$E(SM,1,I-1)
     27 I $D(^SC(SC,"S",DR,"MES")) D CAN S X=SDSAVX K SDSAVX S DR=+$O(^SC(SC,"S",DR)) G:DR\1=X I G OVR
     28 F Y=0:0 S Y=$O(^SC(SC,"S",DR,1,Y)) Q:Y'>0  I $P(^(Y,0),"^",9)'["C" S SDSL=$P(^(0),U,2)/SL*(SL\(60/SDSI))*HSI-HSI F I=0:HSI:SDSL S ST=$E(S,I+2) S:ST="" ST=" " S S=$E(S,1,I+2-1)_$E(STR,$F(STR,ST)-2)_$E(S,I+3,999)
     29 S SM=SM_S,DR=$O(^SC(SC,"S",DR)) I DR\1=X G I
     30OVR I $L(SM)>SM S ^SC(SC,"ST",X,0)=X,^(1)=SM S:SS'>0 ^(9)=SC
     31 G Z
     32SM S SM=$P("SU^MO^TU^WE^TH^FR^SA",U,DOW+1)_" "_$E(X,6,7)_$J("",SI+SI-6)_DH_$J("",64-$L(DH)) Q
     33APPT S DR=+$O(^SC(SC,"S",DATE)),SDAPPT=0 I DR>(DATE_.9) S DR=DATE Q
     34 F DR1=DATE:0 S DR1=$O(^SC(SC,"S",DR1)) Q:DR1'>0!(DR1>(DATE+1))!(SDAPPT)  S:$D(^(DR1,"MES")) SDAPPT=1 F SDAPPT1=0:0 S SDAPPT1=$O(^SC(SC,"S",DR1,1,SDAPPT1)) Q:SDAPPT1'>0  I $D(^(SDAPPT1,0)) S SDAPPT=$S($P(^(0),"^",9)="C":0,1:1)
     35 Q
     36CAN S SDSAVX=X Q:'$D(^SC(SC,"SDCAN",DR,0))  S X=$E($P(DR,".",2)_"0000",1,4),I=SM_S D TT S ST=%,X=$P(^SC(SC,"SDCAN",DR,0),"^",2) D TT S I=I_$J("",%-$L(I)),Y=""
     37 F X=0:2:% S S=$E(I,X+SI+SI),P=$S(X<ST:S_$E(I,X+1+SI+SI),X=%:$S(Y="[":Y,1:S)_$E(I,X+1+SI+SI),1:$S(Y="["&(X=ST):"]",1:"X")_"X"),Y=$S(S="]":"",S="[":S,1:Y),I=$E(I,1,X-1+SI+SI)_P_$E(I,X+2+SI+SI,999)
     38 S SM=I Q
     39TT S %=$E(X,3,4),%=X\100-STARTDAY*SI+(%*SI\60)*2 Q
     40PRNT U IO S YP=YP+1 D:YP>(IOSL-4) ESC^SDD W !,$E(SDNM,1,25),?27,$E(DAY,1,3)_" " S Y=DATE D DT^DIO2 W ?45,MSG Q
     41ESC S SDU=0 I $E(IOST,1,2)="C-" W *7 R ESC:DTIME S:U=ESC SDU=1

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDLT.m

    r613 r623  
    1 SDLT    ;ALB/LDB - CANCELLATION LETTERS ; 14 Feb 2003
    2         ;;5.3;Scheduling;**185,213,281,330,398,523**;Aug 13, 1993;Build 6
    3         ;
    4         ;**************************************************************************
    5         ;                          MODIFICATIONS
    6         ;                         
    7         ;   DATE      PATCH     DEVELOPER  DESCRIPTION OF CHANGES
    8         ; --------  ----------  ---------  ----------------------------------------
    9         ; 02/14/03  SD*5.3*281  SAUNDERS   Print letters to confidential address if
    10         ;                                  requested
    11         ; 12/2/03   SD*5.3*330  LUNDEN     Remove form feed from PRT+0
    12         ;
    13         ;**************************************************************************
    14         ;
    15         ;WRITE GREETING AND OPENING TEXT OF LETTER
    16 PRT     S DFN=$P(A,U,1)  ;SD*523
    17         I $D(SDNOSH) I $D(^DPT(DFN,.1)) S POP=1 Q:POP  ;SD/523
    18         S Y=DT D DTS^SDUTL
    19         I +$G(SDFIRST)=0 W @IOF ;SD*5.3*330 Form feed only after letter #1
    20         K SDFIRST
    21         ;S SDFIRST=0
    22         W !,?65,Y,!,?65,$$LAST4(A),!!!!
    23         I 'SDFORM W !!!!! D ADDR W !!!!
    24 W1      W !,"Dear ",$S($P(^DPT(+A,0),"^",2)="M":"Mr. ",1:"Ms. ")
    25         N DPTNAME
    26         S DPTNAME("FILE")=2,DPTNAME("FIELD")=".01",DPTNAME("IENS")=(+A)_","
    27         S X=$$NAMEFMT^XLFNAME(.DPTNAME,"G","M") W X,","
    28         W !! K ^UTILITY($J,"W"),DIWF,DIWR,DIWF S DIWL=1,DIWF="C80WN" F Z0=0:0 S Z0=$O(^VA(407.5,SDLET,1,Z0)) Q:Z0'>0  S X=^(Z0,0) D ^DIWP
    29         D ^DIWW K ^UTILITY($J,"W") Q
    30 WRAPP   ;WRITE APPOINTMENT INFORMATION
    31         S:$D(SC)&'$D(SDC) SDC=SC S SDCL=$P(^SC(+SDC,0),"^",1),SDCL=SDCL_" Clinic" D FORM
    32         S SDX1=$S($D(SDX):SDX,1:X) S:$D(SDS) S=SDS F B=3,4,5 I $P(S,"^",B)]"" S SDCL=$S(B=3:"LAB",B=4:"XRAY",1:"EKG"),SDX=$P(S,"^",B) D FORM
    33         S (SDX,X)=SDX1 Q
    34 FORM    S:$D(SDX) X=SDX S SDHX=X D DW^%DTC S DOW=X,X=SDHX X ^DD("FUNC",2,1) S SDT0=X,SDDAT=$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",$E(SDHX,4,5))_" "_+$E(SDHX,6,7)_", "_(1700+$E(SDHX,1,3)) W !?4,DOW,?14,$J(SDDAT,12)
    35         W ?27,$J(SDT0,8)," ",SDCL I $D(SDLT)&($Y>(IOSL-8)) W @IOF
    36         Q
    37 REST    ;WRITE THE REMAINDER OF LETTER
    38         I SDLET W !?12 K ^UTILITY($J,"W"),DIWL,DIWR,DIWF S DIWL=1,DIWF="C80WN" F Z5=0:0 S Z5=$O(^VA(407.5,SDLET,2,Z5)) Q:Z5'>0  S X=^(Z5,0) D ^DIWP
    39         D ^DIWW K ^UTILITY($J,"W") Q:'SDFORM
    40         F I=$Y:1:IOSL-12 W !
    41         D ADDR Q
    42 ADDR    K VAHOW S DFN=+A W !?12,$$FML^DGNFUNC(DFN) S VAHOW=2
    43         I $D(^DG(43,1,"BT")),'$P(^("BT"),"^",3) S VAPA("P")=""
    44         S X1=DT,X2=5 D C^%DTC I '$D(VAPA("P")) S (VATEST("ADD",9),VATEST("ADD",10))=X
    45         D ADD^VADPT D
    46         .;CHANGE STATE TO ABBR.
    47         .N SDIENS,X
    48         .I $D(^UTILITY("VAPA",$J,5)) S SDIENS=+^UTILITY("VAPA",$J,5)_",",X=$$GET1^DIQ(5,SDIENS,1),$P(^UTILITY("VAPA",$J,5),U,2)=X
    49         .K SDIENS Q
    50         N SDCCACT1,SDCCACT2
    51         S SDCCACT1=^UTILITY("VAPA",$J,12),SDCCACT2=$P($G(^UTILITY("VAPA",$J,22,2)),"^",3)
    52         ;if confidential address is not active for scheduling/appointment letters, print to regular address
    53         I ($G(SDCCACT1)=0)!($G(SDCCACT2)'="Y") D
    54         .F LL=1:1:4 W:^UTILITY("VAPA",$J,LL)]"" !,?12,^UTILITY("VAPA",$J,LL)
    55         .W:^UTILITY("VAPA",$J,4)']"" ! I ^UTILITY("VAPA",$J,5)]"" W ", ",$P(^UTILITY("VAPA",$J,5),"^",2)
    56         .I ^UTILITY("VAPA",$J,11)]"" W "  ",$P(^UTILITY("VAPA",$J,11),U,2)
    57         ;if confidential address is active for scheduling/appointment letters, print to confidential address
    58         I $G(SDCCACT1)=1,$G(SDCCACT2)="Y" D
    59         .F LL=13:1:16 W:^UTILITY("VAPA",$J,LL)]"" !,?12,^UTILITY("VAPA",$J,LL)
    60         .W:^UTILITY("VAPA",$J,16)']"" ! I ^UTILITY("VAPA",$J,17)]"" W ", ",$P(^UTILITY("VAPA",$J,17),"^",2)
    61         .I ^UTILITY("VAPA",$J,18)]"" W "  ",$P(^UTILITY("VAPA",$J,18),U,2)
    62         W ! D KVAR^VADPT Q
    63         ;
    64         ;
    65 LAST4(DFN)      ;Return patient "last four"
    66         N SDX
    67         S SDX=$G(^DPT(+DFN,0))
    68         Q $E(SDX)_$E($P(SDX,U,9),6,9)
    69         ;
    70 BADADD  ;Print patients with a Bad Address Indicator
    71         I '$D(^TMP($J,"BADADD")) Q
    72         N SDHDR,SDHDR1
    73         W @IOF,$TR($J("",IOM)," ","*")
    74         S SDHDR="BAD ADDRESS INDICATOR LIST" W !,?(IOM-$L(SDHDR)/2),SDHDR,!
    75         S SDHDR1="** THE LETTER FOR THESE PATIENT(S) DID NOT PRINT DUE TO A BAD ADDRESS INDICATOR."
    76         W !,"Last 4",!,"of SSN",?10,"Patient Name",!
    77         W $TR($J("",IOM)," ","*")
    78         N SDNAM,SDDFN
    79         S SDNAM="" F  S SDNAM=$O(^TMP($J,"BADADD",SDNAM)) Q:SDNAM=""  D
    80         . S SDDFN=0 F  S SDDFN=$O(^TMP($J,"BADADD",SDNAM,SDDFN)) Q:'SDDFN  D
    81         . . W !,$$LAST4(SDDFN),?10,SDNAM
    82         W !!,SDHDR1
    83         Q
     1SDLT ;ALB/LDB - CANCELLATION LETTERS ; 14 Feb 2003
     2 ;;5.3;Scheduling;**185,213,281,330,398**;Aug 13, 1993
     3 ;
     4 ;**************************************************************************
     5 ;                          MODIFICATIONS
     6 ;                         
     7 ;   DATE      PATCH     DEVELOPER  DESCRIPTION OF CHANGES
     8 ; --------  ----------  ---------  ----------------------------------------
     9 ; 02/14/03  SD*5.3*281  SAUNDERS   Print letters to confidential address if
     10 ;                                  requested
     11 ; 12/2/03   SD*5.3*330  LUNDEN     Remove form feed from PRT+0
     12 ;
     13 ;**************************************************************************
     14 ;
     15 ;WRITE GREETING AND OPENING TEXT OF LETTER
     16PRT S Y=DT D DTS^SDUTL
     17 I +$G(SDFIRST)=0 W @IOF ;SD*5.3*330 Form feed only after letter #1
     18 K SDFIRST
     19 ;S SDFIRST=0
     20 W !,?65,Y,!,?65,$$LAST4(A),!!!!
     21 I 'SDFORM W !!!!! D ADDR W !!!!
     22W1 W !,"Dear ",$S($P(^DPT(+A,0),"^",2)="M":"Mr. ",1:"Ms. ")
     23 N DPTNAME
     24 S DPTNAME("FILE")=2,DPTNAME("FIELD")=".01",DPTNAME("IENS")=(+A)_","
     25 S X=$$NAMEFMT^XLFNAME(.DPTNAME,"G","M") W X,","
     26 W !! K ^UTILITY($J,"W"),DIWF,DIWR,DIWF S DIWL=1,DIWF="C80WN" F Z0=0:0 S Z0=$O(^VA(407.5,SDLET,1,Z0)) Q:Z0'>0  S X=^(Z0,0) D ^DIWP
     27 D ^DIWW K ^UTILITY($J,"W") Q
     28WRAPP ;WRITE APPOINTMENT INFORMATION
     29 S:$D(SC)&'$D(SDC) SDC=SC S SDCL=$P(^SC(+SDC,0),"^",1),SDCL=SDCL_" Clinic" D FORM
     30 S SDX1=$S($D(SDX):SDX,1:X) S:$D(SDS) S=SDS F B=3,4,5 I $P(S,"^",B)]"" S SDCL=$S(B=3:"LAB",B=4:"XRAY",1:"EKG"),SDX=$P(S,"^",B) D FORM
     31 S (SDX,X)=SDX1 Q
     32FORM S:$D(SDX) X=SDX S SDHX=X D DW^%DTC S DOW=X,X=SDHX X ^DD("FUNC",2,1) S SDT0=X,SDDAT=$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",$E(SDHX,4,5))_" "_+$E(SDHX,6,7)_", "_(1700+$E(SDHX,1,3)) W !?4,DOW,?14,$J(SDDAT,12)
     33 W ?27,$J(SDT0,8)," ",SDCL I $D(SDLT)&($Y>(IOSL-8)) W @IOF
     34 Q
     35REST ;WRITE THE REMAINDER OF LETTER
     36 I SDLET W !?12 K ^UTILITY($J,"W"),DIWL,DIWR,DIWF S DIWL=1,DIWF="C80WN" F Z5=0:0 S Z5=$O(^VA(407.5,SDLET,2,Z5)) Q:Z5'>0  S X=^(Z5,0) D ^DIWP
     37 D ^DIWW K ^UTILITY($J,"W") Q:'SDFORM
     38 F I=$Y:1:IOSL-12 W !
     39 D ADDR Q
     40ADDR K VAHOW S DFN=+A W !?12,$$FML^DGNFUNC(DFN) S VAHOW=2
     41 I $D(^DG(43,1,"BT")),'$P(^("BT"),"^",3) S VAPA("P")=""
     42 S X1=DT,X2=5 D C^%DTC I '$D(VAPA("P")) S (VATEST("ADD",9),VATEST("ADD",10))=X
     43 D ADD^VADPT D
     44 .;CHANGE STATE TO ABBR.
     45 .N SDIENS,X
     46 .I $D(^UTILITY("VAPA",$J,5)) S SDIENS=+^UTILITY("VAPA",$J,5)_",",X=$$GET1^DIQ(5,SDIENS,1),$P(^UTILITY("VAPA",$J,5),U,2)=X
     47 .K SDIENS Q
     48 N SDCCACT1,SDCCACT2
     49 S SDCCACT1=^UTILITY("VAPA",$J,12),SDCCACT2=$P($G(^UTILITY("VAPA",$J,22,2)),"^",3)
     50 ;if confidential address is not active for scheduling/appointment letters, print to regular address
     51 I ($G(SDCCACT1)=0)!($G(SDCCACT2)'="Y") D
     52 .F LL=1:1:4 W:^UTILITY("VAPA",$J,LL)]"" !,?12,^UTILITY("VAPA",$J,LL)
     53 .W:^UTILITY("VAPA",$J,4)']"" ! I ^UTILITY("VAPA",$J,5)]"" W ", ",$P(^UTILITY("VAPA",$J,5),"^",2)
     54 .I ^UTILITY("VAPA",$J,11)]"" W "  ",$P(^UTILITY("VAPA",$J,11),U,2)
     55 ;if confidential address is active for scheduling/appointment letters, print to confidential address
     56 I $G(SDCCACT1)=1,$G(SDCCACT2)="Y" D
     57 .F LL=13:1:16 W:^UTILITY("VAPA",$J,LL)]"" !,?12,^UTILITY("VAPA",$J,LL)
     58 .W:^UTILITY("VAPA",$J,16)']"" ! I ^UTILITY("VAPA",$J,17)]"" W ", ",$P(^UTILITY("VAPA",$J,17),"^",2)
     59 .I ^UTILITY("VAPA",$J,18)]"" W "  ",$P(^UTILITY("VAPA",$J,18),U,2)
     60 W ! D KVAR^VADPT Q
     61 ;
     62 ;
     63LAST4(DFN) ;Return patient "last four"
     64 N SDX
     65 S SDX=$G(^DPT(+DFN,0))
     66 Q $E(SDX)_$E($P(SDX,U,9),6,9)
     67 ;
     68BADADD ;Print patients with a Bad Address Indicator
     69 I '$D(^TMP($J,"BADADD")) Q
     70 N SDHDR,SDHDR1
     71 W @IOF,$TR($J("",IOM)," ","*")
     72 S SDHDR="BAD ADDRESS INDICATOR LIST" W !,?(IOM-$L(SDHDR)/2),SDHDR,!
     73 S SDHDR1="** THE LETTER FOR THESE PATIENT(S) DID NOT PRINT DUE TO A BAD ADDRESS INDICATOR."
     74 W !,"Last 4",!,"of SSN",?10,"Patient Name",!
     75 W $TR($J("",IOM)," ","*")
     76 N SDNAM,SDDFN
     77 S SDNAM="" F  S SDNAM=$O(^TMP($J,"BADADD",SDNAM)) Q:SDNAM=""  D
     78 . S SDDFN=0 F  S SDDFN=$O(^TMP($J,"BADADD",SDNAM,SDDFN)) Q:'SDDFN  D
     79 . . W !,$$LAST4(SDDFN),?10,SDNAM
     80 W !!,SDHDR1
     81 Q

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDN1.m

    r613 r623  
    1 SDN1    ;BSN/GRR - NO-SHOW LETTERS ; 17 AUG 84  4:34 pm
    2         ;;5.3;Scheduling;**330,340,398,455,523**;Aug 13, 1993;Build 6
    3         N SDBAD
    4         I ANS["Y"&($D(C)) F A=0:0 S A=$O(^UTILITY($J,A)) Q:A'>0  F C=0:0 S C=$O(^(A,C)) Q:C'>0  S SC=+^(C),SDLET="" S:$D(^SC(SC,"LTR")) SDLET=+^("LTR") S:SDLET ^UTILITY($J,"SDLT",SDLET,A,C)=^UTILITY($J,A,C) S:'SDLET ^UTILITY($J,"NO",A,C)=SC D KLL
    5         S SDFORM=$S($D(^DG(40.8,SDV1,"LTR")):^("LTR"),1:"") G:ANS["Y"&($D(C)) LST
    6 BC      K:$D(SDLT) C S:$D(SDLT) SDT=SDBD,DATEND=SDED K ^UTILITY($J) I $D(C) K VAUTC S (VAUTC,VAUTC(C))=""
    7         I $D(VAUTC),'VAUTC F C=0:0 S C=$O(VAUTC(C)) Q:C'>0  D:$D(SDLT) LT D CHECK1 I $T D OVER
    8         I $D(VAUTC),'VAUTC G LST
    9 LST1    F C=0:0 S C=$O(^SC(C)) Q:C'>0  D LT,CHECK1 I $T,$S(SDV1="":1,SDV=SDV1:1,SDV="":1,1:0),'$D(SDVAUTC(+C)),$D(^SC(C,"S")) D OVER
    10 LST     N SDFIRST S SDFIRST=1
    11         F SDLET=0:0 S SDLET=$O(^UTILITY($J,"SDLT",SDLET)) Q:SDLET'>0  F A=0:0 S A=$O(^UTILITY($J,"SDLT",SDLET,A)) Q:A'>0  I $S('$D(^DPT(A,.35)):1,$P(^(.35),"^",1)']"":1,1:0) N POP S POP=0 D ^SDLT Q:POP  D WR  ;SD*523 added quit
    12         I $D(^UTILITY($J,"NO")) W @IOF F A=0:0 S A=$O(^UTILITY($J,"NO",A)) Q:A'>0  F A1=0:0 S A1=$O(^(A,A1)) Q:A1'>0  Q:$$BADADR^DGUTL3(A)  W !,$P(^DPT(A,0),"^")," ",$P(^(0),"^",9)," has failed to keep the following appointment(s):" D NDT
    13         W:$D(^UTILITY($J,"NO")) !,"However, there are no letters assigned to the clinic(s).",!!
    14         I $D(^TMP($J,"BADADD")) D BADADD^SDLT K ^TMP($J,"BADADD")
    15         G END
    16 OVER    S GDATE=SDT Q:'$D(^SC(C,"S"))  F J=0:0 S GDATE=$O(^SC(C,"S",GDATE)) Q:GDATE=""!(GDATE>(DATEND+.9999))  F K=0:0 S K=$O(^SC(C,"S",GDATE,1,K)) Q:K=""  I $D(^(K,0)) S DFN=+^(0) D CHECK
    17         Q
    18 END     K %,%DT,%IS,A,A0,A1,A2,ALL,ALS,ANS,BY,C,CDATE,DA,DFN,DGPGM,DGVAR,DH,DHD,DIC,DIS,DIV,DIW,DIWF,DIWL,DIWR,DIWT,DO,DOW,DN,DUPE,FLDS,F,F1,FR,GDATE,I,I1,L,L0,LET,MAX,MESS,MIN,NOAP,P,POP,SC,SD,SDFOR,SDLET,SDTIME,SI,SL,SS,ST,SDSTRTDT,TO,X,Y,ADDR,B
    19         K CLIN,HX,LL,PDAT,S,TIME,Z,D,NDATE,ENDATE,J,SDMDT,SDMSTIME,X1,X2,SDTADE,SDADTB,SDRE,SDRE1,SDIN,SDIS,SDYES,CNN,SDT,DATEND,SDV1,K,SDR,SDJ1,^UTILITY($J),SD1,SD2,SDADD,SDC,SDCL,SDCMAX,SDCONS,SDD,SDDAT,SDDIF,SDDT,SDED,SDFORM,SDHX,SDINP,SDIP
    20         K %ZIS,Y1,SDBD,SDCT,SDVAUTC,VAUTC,SDX,SDX1,SDNOSH,SDLT1,SDMSG,SDNODE,SDQ,SDRT,SDSOH,SDSTAT,SDT0,SDZSC,SM,SM1,STARTDAY,STIME,SDV,Z0,Z5 D CLOSE^DGUTQ Q
    21 CHECK   I $S('$D(^DPT(DFN,.35)):1,$P(^(.35),"^",1)']"":1,1:0),$D(^DPT(DFN,"S",GDATE,0)),$S($P(^(0),U,2)="N":1,$P(^(0),U,2)="NA":1,$D(SDCP)&$P(^(0),"^",2)["C":1,1:0),$P(^(0),"^",14)=SDTIME!(SDTIME="*"),'$D(^DPT(DFN,.1)) D
    22         .D BAD Q:SDBAD
    23         .D SET
    24         Q  ;above logic changed SD*5.3*455
    25 SET     I SDLT1!SDLET S ^UTILITY($J,"SDLT",$S(SDLT1:SDLT1,1:SDLET),DFN,GDATE)=C_"^"_$P(^DPT(DFN,"S",GDATE,0),"^",10) Q
    26         S ^UTILITY($J,"NO",DFN,GDATE)=C Q
    27 CHECK1  S SDV=$P(^SC(C,0),"^",15) I $P(^(0),"^",3)="C",$S('$D(^SC(C,"I")):1,'(+^("I")):1,+^("I")>DATEND:1,+$P(^("I"),"^",2)'>DATEND&(+$P(^("I"),"^",2)):1,1:0)
    28         Q
    29 WR      K CNN F J=0:0 S J=$O(^UTILITY($J,"SDLT",SDLET,A,J)) Q:J=""  S SDR=0,SDX=J,CNN(J)=^(J),CLIN=$P(^SC(+$P(CNN(J),"^",1),0),"^",1),SDC=+CNN(J),S=$S($D(^DPT(A,"S",J,0)):^(0),1:"") D WRAPP^SDLT,SET1
    30         D:SDR SDR D REST^SDLT Q
    31 SDR     W !!,"The appointment(s) have been rescheduled as follows:",!
    32         F J=0:0 S J=$O(CNN(J)) Q:J=""  S SDX=$P(CNN(J),"^",2),SDC=$P(CNN(J),"^") I SDX S S=$S($D(^DPT(A,"S",SDX,0)):^(0),1:"") D WRAPP^SDLT
    33         Q
    34 SET1    S:'SDR SDR=$S($P(CNN(J),"^",2)]"":1,1:0) Q
    35         Q
    36 LT      S:'SDLT1 SDLET=0 I $D(^SC(C,"LTR")),^("LTR") S SDLET=+^("LTR")
    37         Q
    38 NDT     W !?15,$P(^SC(+^UTILITY($J,"NO",A,A1),0),"^")," on " S Y=A1 D DT^DIQ Q
    39 KLL     K ^UTILITY($J,A,C) Q
    40 BAD     S SDBAD=$$BADADR^DGUTL3(+DFN)
    41         S:SDBAD ^TMP($J,"BADADD",$P(^DPT(+DFN,0),"^"),+DFN)=""
    42         Q
     1SDN1 ;BSN/GRR - NO-SHOW LETTERS ; 17 AUG 84  4:34 pm
     2 ;;5.3;Scheduling;**330,340,398,455**;Aug 13, 1993
     3 N SDBAD
     4 I ANS["Y"&($D(C)) F A=0:0 S A=$O(^UTILITY($J,A)) Q:A'>0  F C=0:0 S C=$O(^(A,C)) Q:C'>0  S SC=+^(C),SDLET="" S:$D(^SC(SC,"LTR")) SDLET=+^("LTR") S:SDLET ^UTILITY($J,"SDLT",SDLET,A,C)=^UTILITY($J,A,C) S:'SDLET ^UTILITY($J,"NO",A,C)=SC D KLL
     5 S SDFORM=$S($D(^DG(40.8,SDV1,"LTR")):^("LTR"),1:"") G:ANS["Y"&($D(C)) LST
     6BC K:$D(SDLT) C S:$D(SDLT) SDT=SDBD,DATEND=SDED K ^UTILITY($J) I $D(C) K VAUTC S (VAUTC,VAUTC(C))=""
     7 I $D(VAUTC),'VAUTC F C=0:0 S C=$O(VAUTC(C)) Q:C'>0  D:$D(SDLT) LT D CHECK1 I $T D OVER
     8 I $D(VAUTC),'VAUTC G LST
     9LST1 F C=0:0 S C=$O(^SC(C)) Q:C'>0  D LT,CHECK1 I $T,$S(SDV1="":1,SDV=SDV1:1,SDV="":1,1:0),'$D(SDVAUTC(+C)),$D(^SC(C,"S")) D OVER
     10LST N SDFIRST S SDFIRST=1
     11 F SDLET=0:0 S SDLET=$O(^UTILITY($J,"SDLT",SDLET)) Q:SDLET'>0  F A=0:0 S A=$O(^UTILITY($J,"SDLT",SDLET,A)) Q:A'>0  I $S('$D(^DPT(A,.35)):1,$P(^(.35),"^",1)']"":1,1:0) D ^SDLT,WR
     12 I $D(^UTILITY($J,"NO")) W @IOF F A=0:0 S A=$O(^UTILITY($J,"NO",A)) Q:A'>0  F A1=0:0 S A1=$O(^(A,A1)) Q:A1'>0  Q:$$BADADR^DGUTL3(A)  W !,$P(^DPT(A,0),"^")," ",$P(^(0),"^",9)," has failed to keep the following appointment(s):" D NDT
     13 W:$D(^UTILITY($J,"NO")) !,"However, there are no letters assigned to the clinic(s).",!!
     14 I $D(^TMP($J,"BADADD")) D BADADD^SDLT K ^TMP($J,"BADADD")
     15 G END
     16OVER S GDATE=SDT Q:'$D(^SC(C,"S"))  F J=0:0 S GDATE=$O(^SC(C,"S",GDATE)) Q:GDATE=""!(GDATE>(DATEND+.9999))  F K=0:0 S K=$O(^SC(C,"S",GDATE,1,K)) Q:K=""  I $D(^(K,0)) S DFN=+^(0) D CHECK
     17 Q
     18END K %,%DT,%IS,A,A0,A1,A2,ALL,ALS,ANS,BY,C,CDATE,DA,DFN,DGPGM,DGVAR,DH,DHD,DIC,DIS,DIV,DIW,DIWF,DIWL,DIWR,DIWT,DO,DOW,DN,DUPE,FLDS,F,F1,FR,GDATE,I,I1,L,L0,LET,MAX,MESS,MIN,NOAP,P,POP,SC,SD,SDFOR,SDLET,SDTIME,SI,SL,SS,ST,SDSTRTDT,TO,X,Y,ADDR,B
     19 K CLIN,HX,LL,PDAT,S,TIME,Z,D,NDATE,ENDATE,J,SDMDT,SDMSTIME,X1,X2,SDTADE,SDADTB,SDRE,SDRE1,SDIN,SDIS,SDYES,CNN,SDT,DATEND,SDV1,K,SDR,SDJ1,^UTILITY($J),SD1,SD2,SDADD,SDC,SDCL,SDCMAX,SDCONS,SDD,SDDAT,SDDIF,SDDT,SDED,SDFORM,SDHX,SDINP,SDIP
     20 K %ZIS,Y1,SDBD,SDCT,SDVAUTC,VAUTC,SDX,SDX1,SDNOSH,SDLT1,SDMSG,SDNODE,SDQ,SDRT,SDSOH,SDSTAT,SDT0,SDZSC,SM,SM1,STARTDAY,STIME,SDV,Z0,Z5 D CLOSE^DGUTQ Q
     21CHECK I $S('$D(^DPT(DFN,.35)):1,$P(^(.35),"^",1)']"":1,1:0),$D(^DPT(DFN,"S",GDATE,0)),$S($P(^(0),U,2)="N":1,$P(^(0),U,2)="NA":1,$D(SDCP)&$P(^(0),"^",2)["C":1,1:0),$P(^(0),"^",14)=SDTIME!(SDTIME="*"),'$D(^DPT(DFN,.1)) D
     22 .D BAD Q:SDBAD
     23 .D SET
     24 Q  ;above logic changed SD*5.3*455
     25SET I SDLT1!SDLET S ^UTILITY($J,"SDLT",$S(SDLT1:SDLT1,1:SDLET),DFN,GDATE)=C_"^"_$P(^DPT(DFN,"S",GDATE,0),"^",10) Q
     26 S ^UTILITY($J,"NO",DFN,GDATE)=C Q
     27CHECK1 S SDV=$P(^SC(C,0),"^",15) I $P(^(0),"^",3)="C",$S('$D(^SC(C,"I")):1,'(+^("I")):1,+^("I")>DATEND:1,+$P(^("I"),"^",2)'>DATEND&(+$P(^("I"),"^",2)):1,1:0)
     28 Q
     29WR K CNN F J=0:0 S J=$O(^UTILITY($J,"SDLT",SDLET,A,J)) Q:J=""  S SDR=0,SDX=J,CNN(J)=^(J),CLIN=$P(^SC(+$P(CNN(J),"^",1),0),"^",1),SDC=+CNN(J),S=$S($D(^DPT(A,"S",J,0)):^(0),1:"") D WRAPP^SDLT,SET1
     30 D:SDR SDR D REST^SDLT Q
     31SDR W !!,"The appointment(s) have been rescheduled as follows:",!
     32 F J=0:0 S J=$O(CNN(J)) Q:J=""  S SDX=$P(CNN(J),"^",2),SDC=$P(CNN(J),"^") I SDX S S=$S($D(^DPT(A,"S",SDX,0)):^(0),1:"") D WRAPP^SDLT
     33 Q
     34SET1 S:'SDR SDR=$S($P(CNN(J),"^",2)]"":1,1:0) Q
     35 Q
     36LT S:'SDLT1 SDLET=0 I $D(^SC(C,"LTR")),^("LTR") S SDLET=+^("LTR")
     37 Q
     38NDT W !?15,$P(^SC(+^UTILITY($J,"NO",A,A1),0),"^")," on " S Y=A1 D DT^DIQ Q
     39KLL K ^UTILITY($J,A,C) Q
     40BAD S SDBAD=$$BADADR^DGUTL3(+DFN)
     41 S:SDBAD ^TMP($J,"BADADD",$P(^DPT(+DFN,0),"^"),+DFN)=""
     42 Q

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDNOS0.m

    r613 r623  
    1 SDNOS0  ;ALB/LDB - NO SHOW REPORT ; 07 May 99 10:21 AM
    2         ;;5.3;Scheduling;**20,194,410,517,523**;Aug 13, 1993;Build 6
    3         D END1^SDNOS
    4         S (SDV1,SDIN,SDNM,SDNM1)=0,SDDIVO=SDDIV
    5         I $D(^DG(43,1,"GL")),$P(^("GL"),U,2) S SDV1=1
    6         I SDDIV'="A" S (^UTILITY($J,"SDNO",SDDIV,"***TOT***"),^UTILITY($J,"SDNO",SDDIV,"***N***","***TOT***"),^UTILITY($J,"SDNO",SDDIV,"***NA***","***TOT***"),^UTILITY($J,"SDNO",SDDIV,"***SDNMS***"))=0
    7         I SDDIV="A" D DIVRPT
    8         I SDCL(1)="ALL" S SDCL=0 D SDCL
    9         I SDCL(1)'="ALL" F SDSUB=0:0 S SDSUB=$O(SDCL(SDSUB)) Q:SDSUB=""  S SDCL=SDCL(SDSUB),SDLAB=$S(SDCL?.N1"*".E:"RANGE",1:"SDTST") D @SDLAB
    10         S (P1,SDTOT,SDTOT1)=0,DGTCH="NO-SHOW REPORT^CLINIC^PAGE#",(SDEND,SDHD)=0
    11         D ^SDNOS1
    12         Q
    13         ;
    14 DIVRPT  F SDDIV=0:0 S SDDIV=$O(^DG(40.8,SDDIV)) Q:'SDDIV  S (^UTILITY($J,"SDNO",SDDIV,"***N***","***TOT***"),^UTILITY($J,"SDNO",SDDIV,"***NA***","***TOT***"),^UTILITY($J,"SDNO",SDDIV,"***TOT***"),^UTILITY($J,"SDNO",SDDIV,"***SDNMS***"))=0
    15         Q
    16         ;
    17 SDCL    F SDZ=1:1 S SDCL=$O(^SC(SDCL)) Q:'SDCL  D SDTST
    18         Q
    19         ;
    20 SDTST   S SDNM=0,SDCL1=^SC(SDCL,0) I $P(SDCL1,U,3)'="C" Q
    21         I SDDIVO,SDCL(1),'$D(SDR1) D DATES Q
    22         I $S((SDDIVO&'SDCL(1)&(SDDIVO=$P(SDCL1,U,15))):1,'SDDIVO:1,$D(SDR1)&SDDIVO&($P(SDCL1,U,15)=SDDIVO):1,'$P(SDCL1,U,15)&(SDDIVO=$P(^DG(43,1,"GL"),U,3)):1,'SDV1:1,1:0) S SDIN=0 D:$D(^SC(SDCL,"I")) INAC^SDNOS1A Q:SDIN  D DATES
    23         Q
    24         ;
    25 DATES   S:'SDDIVO SDDIV=$S($P(SDCL1,U,15)&SDV1:$P(SDCL1,U,15),$D(^DG(43,"GL")):$P(^("GL"),U,3),1:$O(^DG(40.8,0)))
    26         Q:$D(^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***TOT***"))  S ^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***TOT***")=0,^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***SDNMS***")=0
    27         S (SDEN,SDBEG)=0,SDBEG1=SDBD F SDZ1=1:1 S SDBEG1=$O(^SC(SDCL,"S",SDBEG1)) Q:SDBEG1'>0  D SDED Q:SDBEG!SDEN  D CHK
    28         S ^UTILITY($J,"SDNO",SDDIV,"***SDNMS***")=SDNM+^UTILITY($J,"SDNO",SDDIV,"***SDNMS***")
    29         Q
    30         ;
    31 SDED    S SDBEG=0,SDEN=0 I $D(SDED),(SDBEG1>(SDED+.99999)) S SDEN=1 Q
    32         I '$D(SDED),(SDBEG1>(SDBD+.99999)) S SDBEG=1 Q
    33         Q
    34         ;Added 2nd Quit below SD/517
    35         ;SD/523 - added Q:SDPAT="" to For loop
    36 CHK     S SDAPP=0 F  S SDAPP=$O(^SC(SDCL,"S",SDBEG1,1,SDAPP)) Q:'SDAPP  Q:'$D(^(SDAPP,0))  I $D(^SC(SDCL,"S",SDBEG1,1,SDAPP))=10,$P(^(SDAPP,0),U,9)'="C" S SDPAT=$P(^SC(SDCL,"S",SDBEG1,1,SDAPP,0),U,1) Q:SDPAT=""  I $D(^DPT(SDPAT,"S",SDBEG1)) D CHK1
    37         Q
    38         ;
    39 CHK1    S SD="SD" F SDCHK=1,2,10,12,14 S @(SD_SDCHK)=$P(^DPT(SDPAT,"S",SDBEG1,0),U,SDCHK)
    40         S:'SDDIVO&$P(SDCL1,U,15) SDDIV=$P(SDCL1,U,15) S:'SDDIVO&'$P(SDCL1,U,15) SDDIV=$O(^DG(40.8,0))
    41         S:'$D(^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***TOT***")) ^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***TOT***")=0
    42         I SDFMT=1 D
    43         .I (SD2="N")!(SD2="NA"),$$NOSHOW(SDPAT,SDBEG1,SDCL,$G(^DPT(SDPAT,"S",SDBEG1,0)),SDAPP) D
    44         ..D SET,TOTAL Q
    45         I SDFMT=2 D
    46         .I (SD2=""&('$D(^SC(SDCL,"S",SDBEG1,1,SDAPP,"C"))))!(SD2="N")!(SD2="NA")!(SD2="NT"),$$NOSHOW(SDPAT,SDBEG1,SDCL,$G(DPT(SDPAT,"S",SDBEG1,0)),SDAPP) D
    47         ..D SET,TOTAL Q
    48         I SD2'["C" S SDNM=SDNM+1,^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***SDNMS***")=SDNM
    49         Q
    50         ;
    51 SET     S:$P(SDCL1,U,15)&SDDIVO&SDV1 SDDIV=$P(SDCL1,U,15) S ^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),SDBEG1,$P(^DPT(SDPAT,0),U),+$P(^(0),U,9))=SD2_U_SD10_U_SD12
    52         Q
    53         ;
    54 TOTAL   S ^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***"_SD2_"***","***TOT***")=$S($D(^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***"_SD2_"***","***TOT***")):^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***"_SD2_"***","***TOT***")+1,1:1)
    55         S ^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),$P(SDBEG1,"."),"***"_SD2_"***","***TOT***")=$S($D(^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),$P(SDBEG1,"."),"***"_SD2_"***","***TOT***")):^("***TOT***")+1,1:1)
    56         S ^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***TOT***")=$S($D(^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***TOT***")):^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***TOT***")+1,1:1)
    57         S ^("***TOT***")=^UTILITY($J,"SDNO",SDDIV,"***TOT***")+1,^("***TOT***")=$S($D(^UTILITY($J,"SDNO",SDDIV,"***"_SD2_"***","***TOT***")):^UTILITY($J,"SDNO",SDDIV,"***"_SD2_"***","***TOT***")+1,1:1)
    58         Q
    59         ;
    60 RANGE   S SDREST=$E(SDCL,$F(SDCL,"*"),$L(SDCL)),SDCL=$E(SDCL,1,($F(SDCL,"*")-2)),SDCL1=^SC(SDCL,0)
    61         S:'SDDIVO SDDIV=$S($P(SDCL1,U,15):$P(SDCL1,U,15),'$P(SDCL1,U,15)&$D(^DG(43,"GL")):$P(^DG(43,"GL"),U,3),1:$O(^DG(40.8,0)))
    62         S SDR1=1,SDR=$P(SDCL1,U) D SDTST K SDR1
    63         S SDREST="1"_""""_SDREST_""""_".E" F SDCXX=1:1 S SDR=$O(^SC("B",SDR)) Q:'(SDR?@SDREST)!(SDR="")  S SDCL=$O(^SC("B",SDR,-1)) S SDR1=1 D RANGE1 K SDR1
    64         Q
    65         ;
    66 RANGE1  S:'SDDIVO SDDIV=$S($P(SDCL1,U,15):$P(SDCL1,U,15),'$P(SDCL1,U,15)&$D(^DG(43,"GL")):$P(^DG(43,"GL"),U,3),1:$O(^DG(40.8,0))) D SDTST
    67         Q
    68         ;
    69 NOSHOW(DFN,SDT,CIFN,PAT,DA)     ;Input:  DFN=Patient IFN, SDT=Appointment D/T
    70         ;  CIFN=Clinic IFN, PAT=Zero node of pat. appt., DA=Clinic appt. IFN
    71         ;                        Output:  1 or 0 for noshow yes/no
    72         N NSQUERY,NS S NS=1,NSQUERY=$$STATUS^SDAM1(DFN,SDT,CIFN,PAT,DA)
    73         I $P(NSQUERY,";",3)["ACTION REQ" S NS=0
    74 NOSHOWQ Q NS
     1SDNOS0 ;ALB/LDB - NO SHOW REPORT ; 07 May 99 10:21 AM
     2 ;;5.3;Scheduling;**20,194,410,517**;Aug 13, 1993;Build 4
     3 D END1^SDNOS
     4 S (SDV1,SDIN,SDNM,SDNM1)=0,SDDIVO=SDDIV
     5 I $D(^DG(43,1,"GL")),$P(^("GL"),U,2) S SDV1=1
     6 I SDDIV'="A" S (^UTILITY($J,"SDNO",SDDIV,"***TOT***"),^UTILITY($J,"SDNO",SDDIV,"***N***","***TOT***"),^UTILITY($J,"SDNO",SDDIV,"***NA***","***TOT***"),^UTILITY($J,"SDNO",SDDIV,"***SDNMS***"))=0
     7 I SDDIV="A" D DIVRPT
     8 I SDCL(1)="ALL" S SDCL=0 D SDCL
     9 I SDCL(1)'="ALL" F SDSUB=0:0 S SDSUB=$O(SDCL(SDSUB)) Q:SDSUB=""  S SDCL=SDCL(SDSUB),SDLAB=$S(SDCL?.N1"*".E:"RANGE",1:"SDTST") D @SDLAB
     10 S (P1,SDTOT,SDTOT1)=0,DGTCH="NO-SHOW REPORT^CLINIC^PAGE#",(SDEND,SDHD)=0
     11 D ^SDNOS1
     12 Q
     13 ;
     14DIVRPT F SDDIV=0:0 S SDDIV=$O(^DG(40.8,SDDIV)) Q:'SDDIV  S (^UTILITY($J,"SDNO",SDDIV,"***N***","***TOT***"),^UTILITY($J,"SDNO",SDDIV,"***NA***","***TOT***"),^UTILITY($J,"SDNO",SDDIV,"***TOT***"),^UTILITY($J,"SDNO",SDDIV,"***SDNMS***"))=0
     15 Q
     16 ;
     17SDCL F SDZ=1:1 S SDCL=$O(^SC(SDCL)) Q:'SDCL  D SDTST
     18 Q
     19 ;
     20SDTST S SDNM=0,SDCL1=^SC(SDCL,0) I $P(SDCL1,U,3)'="C" Q
     21 I SDDIVO,SDCL(1),'$D(SDR1) D DATES Q
     22 I $S((SDDIVO&'SDCL(1)&(SDDIVO=$P(SDCL1,U,15))):1,'SDDIVO:1,$D(SDR1)&SDDIVO&($P(SDCL1,U,15)=SDDIVO):1,'$P(SDCL1,U,15)&(SDDIVO=$P(^DG(43,1,"GL"),U,3)):1,'SDV1:1,1:0) S SDIN=0 D:$D(^SC(SDCL,"I")) INAC^SDNOS1A Q:SDIN  D DATES
     23 Q
     24 ;
     25DATES S:'SDDIVO SDDIV=$S($P(SDCL1,U,15)&SDV1:$P(SDCL1,U,15),$D(^DG(43,"GL")):$P(^("GL"),U,3),1:$O(^DG(40.8,0)))
     26 Q:$D(^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***TOT***"))  S ^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***TOT***")=0,^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***SDNMS***")=0
     27 S (SDEN,SDBEG)=0,SDBEG1=SDBD F SDZ1=1:1 S SDBEG1=$O(^SC(SDCL,"S",SDBEG1)) Q:SDBEG1'>0  D SDED Q:SDBEG!SDEN  D CHK
     28 S ^UTILITY($J,"SDNO",SDDIV,"***SDNMS***")=SDNM+^UTILITY($J,"SDNO",SDDIV,"***SDNMS***")
     29 Q
     30 ;
     31SDED S SDBEG=0,SDEN=0 I $D(SDED),(SDBEG1>(SDED+.99999)) S SDEN=1 Q
     32 I '$D(SDED),(SDBEG1>(SDBD+.99999)) S SDBEG=1 Q
     33 Q
     34 ;Added 2nd Quit below SD/517
     35CHK S SDAPP=0 F  S SDAPP=$O(^SC(SDCL,"S",SDBEG1,1,SDAPP)) Q:'SDAPP  Q:'$D(^(SDAPP,0))  I $D(^SC(SDCL,"S",SDBEG1,1,SDAPP))=10,$P(^(SDAPP,0),U,9)'="C" S SDPAT=$P(^SC(SDCL,"S",SDBEG1,1,SDAPP,0),U,1) I $D(^DPT(SDPAT,"S",SDBEG1)) D CHK1
     36 Q
     37 ;
     38CHK1 S SD="SD" F SDCHK=1,2,10,12,14 S @(SD_SDCHK)=$P(^DPT(SDPAT,"S",SDBEG1,0),U,SDCHK)
     39 S:'SDDIVO&$P(SDCL1,U,15) SDDIV=$P(SDCL1,U,15) S:'SDDIVO&'$P(SDCL1,U,15) SDDIV=$O(^DG(40.8,0))
     40 S:'$D(^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***TOT***")) ^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***TOT***")=0
     41 I SDFMT=1 D
     42 .I (SD2="N")!(SD2="NA"),$$NOSHOW(SDPAT,SDBEG1,SDCL,$G(^DPT(SDPAT,"S",SDBEG1,0)),SDAPP) D
     43 ..D SET,TOTAL Q
     44 I SDFMT=2 D
     45 .I (SD2=""&('$D(^SC(SDCL,"S",SDBEG1,1,SDAPP,"C"))))!(SD2="N")!(SD2="NA")!(SD2="NT"),$$NOSHOW(SDPAT,SDBEG1,SDCL,$G(DPT(SDPAT,"S",SDBEG1,0)),SDAPP) D
     46 ..D SET,TOTAL Q
     47 I SD2'["C" S SDNM=SDNM+1,^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***SDNMS***")=SDNM
     48 Q
     49 ;
     50SET S:$P(SDCL1,U,15)&SDDIVO&SDV1 SDDIV=$P(SDCL1,U,15) S ^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),SDBEG1,$P(^DPT(SDPAT,0),U),+$P(^(0),U,9))=SD2_U_SD10_U_SD12
     51 Q
     52 ;
     53TOTAL S ^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***"_SD2_"***","***TOT***")=$S($D(^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***"_SD2_"***","***TOT***")):^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***"_SD2_"***","***TOT***")+1,1:1)
     54 S ^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),$P(SDBEG1,"."),"***"_SD2_"***","***TOT***")=$S($D(^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),$P(SDBEG1,"."),"***"_SD2_"***","***TOT***")):^("***TOT***")+1,1:1)
     55 S ^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***TOT***")=$S($D(^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***TOT***")):^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***TOT***")+1,1:1)
     56 S ^("***TOT***")=^UTILITY($J,"SDNO",SDDIV,"***TOT***")+1,^("***TOT***")=$S($D(^UTILITY($J,"SDNO",SDDIV,"***"_SD2_"***","***TOT***")):^UTILITY($J,"SDNO",SDDIV,"***"_SD2_"***","***TOT***")+1,1:1)
     57 Q
     58 ;
     59RANGE S SDREST=$E(SDCL,$F(SDCL,"*"),$L(SDCL)),SDCL=$E(SDCL,1,($F(SDCL,"*")-2)),SDCL1=^SC(SDCL,0)
     60 S:'SDDIVO SDDIV=$S($P(SDCL1,U,15):$P(SDCL1,U,15),'$P(SDCL1,U,15)&$D(^DG(43,"GL")):$P(^DG(43,"GL"),U,3),1:$O(^DG(40.8,0)))
     61 S SDR1=1,SDR=$P(SDCL1,U) D SDTST K SDR1
     62 S SDREST="1"_""""_SDREST_""""_".E" F SDCXX=1:1 S SDR=$O(^SC("B",SDR)) Q:'(SDR?@SDREST)!(SDR="")  S SDCL=$O(^SC("B",SDR,-1)) S SDR1=1 D RANGE1 K SDR1
     63 Q
     64 ;
     65RANGE1 S:'SDDIVO SDDIV=$S($P(SDCL1,U,15):$P(SDCL1,U,15),'$P(SDCL1,U,15)&$D(^DG(43,"GL")):$P(^DG(43,"GL"),U,3),1:$O(^DG(40.8,0))) D SDTST
     66 Q
     67 ;
     68NOSHOW(DFN,SDT,CIFN,PAT,DA) ;Input:  DFN=Patient IFN, SDT=Appointment D/T
     69 ;  CIFN=Clinic IFN, PAT=Zero node of pat. appt., DA=Clinic appt. IFN
     70 ;                        Output:  1 or 0 for noshow yes/no
     71 N NSQUERY,NS S NS=1,NSQUERY=$$STATUS^SDAM1(DFN,SDT,CIFN,PAT,DA)
     72 I $P(NSQUERY,";",3)["ACTION REQ" S NS=0
     73NOSHOWQ Q NS

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDRPA00.m

    r613 r623  
    1 SDRPA00 ;BP-OIFO/OWAIN,ESW - Patient Appointment Information Transmission  ; 11/2/04 11:09am  ; 2/24/08 11:25am
    2         ;;5.3;Scheduling;**290,333,349,376,491**;Aug 13,1993;Build 53
    3         ;SD/491 - calling SRPA03 instead of SDRPA04  (dupl)
    4         Q
    5 EN      ;manual entry
    6         N SDI,Y,ZTSK,ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSAVE,RUNID,REC
    7         I '$$RUNCK^SDRPA02() W !,"You attempted to start PAIT outside the authorized transmission dates.",!,"Job has been terminated.",! Q
    8         S RUNID=$O(^SDWL(409.6,":"),-1)
    9         I RUNID S ZTSK=$P(^SDWL(409.6,RUNID,0),"^",2) D STAT^%ZTLOAD I ZTSK(1)=1!(ZTSK(1)=2) W !,"A task is currently active." Q
    10         K ZTSK N SDCON S SDCON=1
    11         S %DT("A")="Queue to run:  "
    12         S %DT="AEFXR" W ! D ^%DT S DT=Y D:Y'=-1  Q:'SDCON
    13         .S ZTDTH=Y,ZTRTN="START^SDRPA00",ZTIO=""
    14         .S ZTDESC="PAIT"
    15         .I RUNID I $P(^SDWL(409.6,RUNID,0),U,7)="" S SDCON=0 D
    16         ..W !,"The previous run errored out, not repaired!",!,"Please address a problem and use SD-PAIT REPAIR to fix the run."
    17         .Q:'SDCON
    18         .F SDI=1:1:20 D ^%ZTLOAD Q:$G(ZTSK)
    19         .I $G(ZTSK) W !,"Task # "_ZTSK_" queued!"
    20         I '$G(ZTSK) W !!,"Task not queued, check Taskman",! Q
    21         W !!,"Task number: ",ZTSK,!
    22         Q
    23 START   ;Tasked entry
    24         N SDOUT,DFN,DFNEND,SDCNT,SDCNT0,RUNID,RUNDT,SDPREV,FIRST,SDDAM,TODAY,SD6A,SD8A,SD68,RUNIDP,SDPR,ZTSKN
    25         I '$$RUNCK^SDRPA02() Q  ;check scheduling
    26         I $G(ZTSK)="" D  Q
    27         . W !,"NOT AN INTERACTIVE OPTION...schedule through TaskMan",!!
    28         S ZTSKN=ZTSK
    29         S SDPR=$O(^SDWL(409.6,":"),-1) ;previous run
    30         I SDPR N SD1 S SD1=0 D  Q:SD1  ;finish if task is still running
    31         .I $P(^SDWL(409.6,SDPR,0),U,7)'="" Q  ; previous task finished
    32         .N ZTSK
    33         .S ZTSK=$P(^SDWL(409.6,SDPR,0),"^",2) D STAT^%ZTLOAD I ZTSK(1)=1!(ZTSK(1)=2) S SD1=1
    34         .;send message
    35         .N SDAMX,XMSUB,XMY,XMTEXT,XMDUZ
    36         .S XMSUB="PAIT BACKGROUND JOB"
    37         .S XMY("G.SD-PAIT")=""
    38         .S XMTEXT="SDAMX("
    39         .S XMDUZ="POSTMASTER"
    40         .S SDAMX(1)="The PAIT requested task has been terminated."
    41         .S SDAMX(2)="The previous task #: "_ZTSK_" run #: "_SDPR_" has not been completed."
    42         .I SD1=1 S SDAMX(3)="It is still running.",SDAMX(4)=""
    43         .E  S SD1=2 D
    44         ..S SDAMX(3)="The previous run errored out, not repaired!"
    45         ..S SDAMX(4)="Address a problem and use option SD-PAIT REPAIR to fix the run."
    46         .D ^XMD
    47         S DIC=409.6,DIC(0)="X"
    48         D NOW^%DTC S TODAY=X
    49         K DO D FILE^DICN
    50         S DA=+Y,DIE=DIC,DR="1///"_ZTSK D ^DIE
    51         ;send START message
    52         D STMES
    53         S (SDOUT,SDCNT)=0
    54         K ^TMP("SDDPT",$J)
    55         N CRUNID S CRUNID=$O(^SDWL(409.6,"AD",ZTSK,""))
    56         S RUNDT=$P(^SDWL(409.6,CRUNID,0),"^")
    57         I SDPR=0 S SDPREV=3020831,FIRST=1 ;first run
    58         E  S SDPREV=$P(^SDWL(409.6,SDPR,0),U,4),FIRST=0 ;
    59         N SDFIN,SDPEN,SDF,SDTR S (RUNID,SDFIN,SDPEN,SDTR,SDF)=0
    60         S SDDAM=SDPREV ;creation date
    61         D NOW^%DTC S TODAY=X
    62         F  S SDDAM=$O(^DPT("ASADM",SDDAM)) Q:SDDAM=""  Q:SDDAM=TODAY!SDOUT  D
    63         .N DFN S DFN=0
    64         .F  S DFN=$O(^DPT("ASADM",SDDAM,DFN)) Q:+DFN'=DFN!SDOUT  D
    65         ..N SDADT S SDADT=0 ;appt date/time
    66         ..S SDADT=0
    67         ..F  S SDADT=$O(^DPT("ASADM",SDDAM,DFN,SDADT)) Q:+SDADT'=SDADT!SDOUT  D
    68         ...I SDADT'>3030000 Q  ;only appointment scheduled for 2003 and later; sd/491
    69         ...I SDDAM'=$$GET1^DIQ(2.98,SDADT_","_DFN_",",20,"I") Q  ;compare creation dates
    70         ...; Check for 'stop task' request
    71         ...S SDCNT=SDCNT+1 I SDCNT#500=0 S SDOUT=$$S^%ZTLOAD I SDOUT D  N SDBCID,SDMCID,SDSTOP D SNDS19^SDRPA07(ZTSK,.SDBCID,.SDMCID) S SDSTOP=1 D MSGT^SDRPA04(CRUNID,SDPEN,SDFIN,,SDSTOP) K ^TMP("SDDPT",$J) Q
    72         ....N DA,DIE,DR,SDD,SDLAST D
    73         ....S SDLAST=$O(^SDWL(409.6,CRUNID,1,"B"),-1) S SDD=$P(^SDWL(409.6,CRUNID,1,SDLAST,0),U,7)-1
    74         ....S DA=CRUNID,DIE=409.6,DR="1.2///"_SDD D ^DIE
    75         ...N SDCL,SDSTAT,SDSTTY
    76         ...S SDCL=$$GET1^DIQ(2.98,SDADT_","_DFN_",",.01,"I")
    77         ...Q:SDCL=""  ; If this happens, there's something wrong.
    78         ...;
    79         ...; Check status.
    80         ...; Appoinment made only before Sep 1, 2003
    81         ...; If it is not the first run, send but don't create a pending file
    82         ...; Otherwise add to pending file.
    83         ...D NOW^%DTC N STODAY S STODAY=X
    84         ...S SDSTAT=$$STATUS^SDRPA05(DFN,SDADT,SDCL,STODAY,1)
    85         ...I $P(SDSTAT,"^")=0 Q
    86         ...N SDCLL S SDCLL=$P(SDSTAT,U,6) I SDCLL'="" S SDCL=SDCLL ;assign a new clinic if from matching non count with encounter
    87         ...S SDSTTY=$P(SDSTAT,U,2),SD6A=$P(SDSTAT,U,3),SD8A=$P(SDSTAT,U,4)
    88         ...I SDSTTY="F" Q:'$$GT90DAYS(SDDAM,3030831)  ; pending and final from 09/01/2003, previously 90 days
    89         ...I SDSTTY="F",SD6A="NM",SD8A="NC" Q  ; skip non-count if not matching count and scheduled date already expired
    90         ...N SDCOA,SDMSHA S SDCOA=$P(SDSTAT,U,5) S SDMSHA=$P(SDSTAT,U)
    91         ...N SDCE Q:'$$DPT^SDRPA08(DFN,.SDCE)  ; Create demographic node of ^TMP file. Quit if this failed.
    92         ...N DIC,DA,X,SDRET D
    93         ....N SDRET S SDRET=$S(SDSTTY="F":"N",1:"Y")
    94         ....S DIC="^SDWL(409.6,"_CRUNID_",1,",DA(1)=CRUNID,DIC("P")=409.69,DIC(0)="X"
    95         ....K DO S X=DFN D FILE^DICN
    96         ....S DA=+Y,DIE=DIC,DR="1///"_SDADT_";4///"_SDRET_";5///"_SD6A_";6///"_SDDAM_";8///"_SD8A_";9////"_SDCL D ^DIE
    97         ....Q
    98         ...D APPT^SDRPA08(DFN,SDADT,$$DTCONV^SDRPA08(SDDAM),SDCL,SDSTAT)
    99         ...S SDFF=$P(SDSTAT,"^",4) D STAT(SDSTTY,SDFF,.SDFIN,.SDPEN,.SDF)
    100         ...S SDTR=SDTR+1 I SDTR=5000 D SNDS19^SDRPA07(ZTSK,.SDBCID,.SDMCID) K ^TMP("SDDPT",$J) S SDTR=0
    101         Q:SDOUT
    102         N SDD S SDD=$O(^DPT("ASADM",TODAY),-1) ;enter the last scanned day
    103         S DA=CRUNID,DIE=409.6,DR="1.2///"_SDD D ^DIE
    104         ; scan the previous runs
    105         S RUNID=0
    106         F  S RUNID=$O(^SDWL(409.6,RUNID)) Q:+RUNID=CRUNID!SDOUT  D
    107         .N APPTID,SDADT,REC
    108         .S APPTID=0
    109         .;scanning only appointments that were sent as 'pending'
    110         .F  S APPTID=$O(^SDWL(409.6,"AE","Y",RUNID,APPTID)) Q:APPTID=""!SDOUT  S REC=$G(^SDWL(409.6,RUNID,1,APPTID,0)) D
    111         ..IF REC="" K ^SDWL(409.6,"AE","Y",RUNID,APPTID) Q  ;anticipate
    112         ..S DFN=$P(REC,"^"),SDADT=$P(REC,"^",2)
    113         ..;evaluate SDADT - appt date/time for possible removal from sending
    114         ..I SDADT'>3030000 N DIK S DIK="^SDWL(409.6,"_RUNID_",1,",DA(1)=RUNID,DA=APPTID D ^DIK ;delete entry; not to be sent; sd/491
    115         ..; Check for 'stop task'
    116         ..S SDCNT=SDCNT+1 I SDCNT#500=0 S SDOUT=$$S^%ZTLOAD I SDOUT N SDBCID,SDMCID,SDSTOP D SNDS19^SDRPA07(ZTSK,.SDBCID,.SDMCID) S SDSTOP=1 D MSGT^SDRPA04(CRUNID,SDPEN,SDFIN,,SDSTOP) K ^TMP("SDDPT",$J) Q  ;
    117         ..N SDCL,SDCLO,SDCE,SDSTAT,SDREJ,SDDAM,SDDAMO
    118         ..S SDCLO=$P(REC,"^",10)
    119         ..S SDREJ=$P(REC,"^",8),SDDAMO=$P(REC,"^",7) ;esw
    120         ..I SDDAMO="" D
    121         ...N SDD S SDD=9999999 F  S SDD=$O(^DPT("ASADM",SDD),-1) Q:SDD'>0  I $D(^DPT("ASADM",SDD,DFN,SDADT)) S SDDAMO=SDD Q
    122         ..Q:SDDAMO=""  ;cannot determine what was original creation date
    123         ..;evaluate if the same creation date
    124         ..S SDDAM=$$GET1^DIQ(2.98,SDADT_","_DFN_",",20,"I")
    125         ..S SDCL=$$GET1^DIQ(2.98,SDADT_","_DFN_",",.01,"I")
    126         ..Q:SDCL=""  ;
    127         ..I SDCLO="" S SDCLO=SDCL
    128         ..I SDDAM'?7N!(SDDAM'>3020831) S SDDAM=SDDAMO ; need to finalize the previously sent
    129         ..; Check status. If it is a termination, continue.
    130         ..Q:$D(^TMP("SDDPT",$J,DFN,SDADT))  ; overridden to be process next time
    131         ..;anothercross reference entry will be created; do not need to quit
    132         ..;Q:$D(^SDWL(409.6,"AC",DFN,SDADT,+$G(CRUNID)))  ;see above
    133         ..S SDSTAT=""
    134         ..I SDDAM'=SDDAMO!(SDCL'=SDCLO) D
    135         ...; create CT status; the current SDADT has different creation date
    136         ...S SDSTAT="S15"_U_"F"_U_"CT"_U_U_U_U_U S SDDAM=SDDAMO,SDCL=SDCLO
    137         ..I SDSTAT="" D NOW^%DTC N SDTODAY S SDTODAY=X S SDSTAT=$$STATUS^SDRPA05(DFN,SDADT,SDCL,SDTODAY,0)
    138         ..I $P(SDSTAT,"^")=0 Q
    139         ..N SDCOA,SDMSHA S SDCOA=$P(SDSTAT,U,5) S SDMSHA=$P(SDSTAT,U),SD6A=$P(SDSTAT,U,3),SD8A=$P(SDSTAT,U,4)
    140         ..N SDCLL S SDCLL=$P(SDSTAT,U,6) I SDCLL'="" S SDCL=SDCLL
    141         ..S SDSTTY=$P(SDSTAT,U,2)
    142         ..I SDSTTY="P"&(SDREJ="") Q  ;do not send in pending status if not rejected ;esw
    143         ..N SDCE Q:'$$DPT^SDRPA08(DFN,.SDCE)  ; Create demographic node of ^TMP file. Quit if this failed.
    144         ..N DIC,DA,X D
    145         ...N SDRET S SDRET=$S(SDSTTY="F":"N",1:"Y")
    146         ...S DIC="^SDWL(409.6,"_CRUNID_",1,",DA(1)=CRUNID,DIC("P")=409.69,DIC(0)="X"
    147         ...K DO S X=DFN D FILE^DICN
    148         ...S DA=+Y,DIE=DIC,DA=+Y,DR="1///"_SDADT_";4///"_SDRET_";5///"_SD6A_";6///"_SDDAM_";8///"_SD8A_";9////"_SDCL D ^DIE
    149         ..N DIC,DA D
    150         ...; not rejected can be sent only as 'S'- sent as final
    151         ...N SDRET S SDRET=$S(SDREJ'="":"R",1:"S") ; indicates that it was: R - sent as rejected, S - sent as final
    152         ...S DIC="^SDWL(409.6,"_RUNID_",1,",DA(1)=RUNID
    153         ...S DA=APPTID,DIE=DIC,DR="4////"_SDRET D ^DIE
    154         ..D APPT^SDRPA08(DFN,SDADT,$$DTCONV^SDRPA08(SDDAM),SDCL,SDSTAT)
    155         ..S SDFF=$P(SDSTAT,"^",4) D STAT(SDSTTY,SDFF,.SDFIN,.SDPEN,.SDF)
    156         ..S SDTR=SDTR+1 I SDTR=5000 D SNDS19^SDRPA07(ZTSK,.SDBCID,.SDMCID) K ^TMP("SDDPT",$J) S SDTR=0
    157         .Q
    158         Q:SDOUT
    159         I $O(^TMP("SDDPT",$J,"")) D SNDS19^SDRPA07(ZTSK,.SDBCID,.SDMCID)
    160         K ^TMP("SDDPT",$J)
    161         D MSGT^SDRPA04(CRUNID,SDPEN,SDFIN)
    162         Q
    163 STMES   ;generate start message
    164         N SDS,SD870,SD87
    165         S SD870=$O(^HLCS(870,"B","SD-PAIT",""))
    166         N ARRAY D GETS^DIQ(870,SD870_",",4,"I","ARRAY")
    167         N SD87 S SD87=SD870_","
    168         S SDSTAT=ARRAY(870,SD87,4,"I")
    169         D NOW^%DTC
    170         N SDDT,SDST S SDDT=%
    171         S SDST=$P($$SITE^VASITE(),"^",3)
    172         N SDAMX,XMSUB,CMY,XMTEXT,XMDUZ
    173         S XMSUB=$G(SDST)_" - PAIT START JOB"
    174         S XMY("G.SD-PAIT")=""
    175         S XMY("S.SD-PAIT-SERVER@FORUM.VA.GOV")=""
    176         S XMTEXT="SDAMX("
    177         S XMDUZ="POSTMASTER"
    178         S SDAMX(1)="The PAIT job has started - TASK #: "_ZTSK
    179         S SDAMX(2)="Site   Started       SD-PAIT status    Task #"
    180         S SDAMX(3)=SDST_"  |"_SDDT_" |"_SDSTAT_"    |"_ZTSK
    181         ;
    182         I SDSTAT="Shutdown" S XMY("VHACIONHD@MED.VA.GOV")="" D
    183         .S SDAMX(4)=" Please start a REMEDY ticket for station "_SDST
    184         .S SDAMX(5)="SD-PAIT Logical Link has to be started."
    185         .S SDAMX(6)="Refer the ticket to Scheduling PAIT."
    186         .S SDAMX(7)=""
    187         D ^XMD
    188         Q
    189         ;
    190 GT90DAYS(X1,X2) ; Date is older than Sep 1st 2003, see specs.
    191         ; X1 - creation date. More efficient to have it set at the top instead of every time this subroutine is called.
    192         ; X2 - comparison date, now sent as Sep 1 2003, both in Vista format cyymmdd
    193         D ^%DTC
    194         Q X>0  ;
    195 STAT(SDSTTY,SDFF,SDFIN,SDPEN,SDF)       ;summarize pending and finals
    196         I SDSTTY="F" S SDFIN=SDFIN+1 Q
    197         I SDSTTY="P" S SDPEN=SDPEN+1 I SDFF="F" S SDF=SDF+1
    198         Q
     1SDRPA00 ;BP-OIFO/OWAIN,ESW - Patient Appointment Information Transmission  ; 11/2/04 11:09am
     2 ;;5.3;Scheduling;**290,333,349,376**;Aug 13,1993
     3 Q
     4EN ;manual entry
     5 N SDI,Y,ZTSK,ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSAVE,RUNID,REC
     6 I '$$RUNCK^SDRPA02() W !,"You attempted to start PAIT outside the authorized transmission dates.",!,"Job has been terminated.",! Q
     7 S RUNID=$O(^SDWL(409.6,":"),-1)
     8 I RUNID S ZTSK=$P(^SDWL(409.6,RUNID,0),"^",2) D STAT^%ZTLOAD I ZTSK(1)=1!(ZTSK(1)=2) W !,"A task is currently active." Q
     9 K ZTSK N SDCON S SDCON=1
     10 S %DT("A")="Queue to run:  "
     11 S %DT="AEFXR" W ! D ^%DT S DT=Y D:Y'=-1  Q:'SDCON
     12 .S ZTDTH=Y,ZTRTN="START^SDRPA00",ZTIO=""
     13 .S ZTDESC="PAIT"
     14 .I RUNID I $P(^SDWL(409.6,RUNID,0),U,7)="" S SDCON=0 D
     15 ..W !,"The previous run errored out, not repaired!",!,"Please address a problem and then use option SD-PAIT REPAIR to fix the run."
     16 .Q:'SDCON
     17 .F SDI=1:1:20 D ^%ZTLOAD Q:$G(ZTSK)
     18 .I $G(ZTSK) W !,"Task # "_ZTSK_" queued!"
     19 I '$G(ZTSK) W !!,"Task not queued, check Taskman",! Q
     20 W !!,"Task number: ",ZTSK,!
     21 Q
     22START ;Tasked entry
     23 N SDOUT,DFN,DFNEND,SDCNT,SDCNT0,RUNID,RUNDT,SDPREV,FIRST,SDDAM,TODAY,SD6A,SD8A,SD68,RUNIDP,SDPR,ZTSKN
     24 I '$$RUNCK^SDRPA02() Q  ;check scheduling
     25 I $G(ZTSK)="" D  Q
     26 . W !,"NOT AN INTERACTIVE OPTION...schedule through TaskMan",!!
     27 S ZTSKN=ZTSK
     28 S SDPR=$O(^SDWL(409.6,":"),-1) ;previous run
     29 I SDPR N SD1 S SD1=0 D  Q:SD1  ;finish if task is still running
     30 .I $P(^SDWL(409.6,SDPR,0),U,7)'="" Q  ; previous task finished
     31 .N ZTSK
     32 .S ZTSK=$P(^SDWL(409.6,SDPR,0),"^",2) D STAT^%ZTLOAD I ZTSK(1)=1!(ZTSK(1)=2) S SD1=1
     33 .;send message
     34 .N SDAMX,XMSUB,XMY,XMTEXT,XMDUZ
     35 .S XMSUB="PAIT BACKGROUND JOB"
     36 .S XMY("G.SD-PAIT")=""
     37 .S XMTEXT="SDAMX("
     38 .S XMDUZ="POSTMASTER"
     39 .S SDAMX(1)="The PAIT requested task has been terminated."
     40 .S SDAMX(2)="The previous task #: "_ZTSK_" run #: "_SDPR_" has not been completed."
     41 .I SD1=1 S SDAMX(3)="It is still running.",SDAMX(4)=""
     42 .E  S SD1=2 D
     43 ..S SDAMX(3)="The previous run errored out, not repaired!"
     44 ..S SDAMX(4)="Address a problem and use option SD-PAIT REPAIR to fix the run."
     45 .D ^XMD
     46 S DIC=409.6,DIC(0)="X"
     47 D NOW^%DTC S TODAY=X
     48 K DO D FILE^DICN
     49 S DA=+Y,DIE=DIC,DR="1///"_ZTSK D ^DIE
     50 ;send START message
     51 D STMES
     52 S (SDOUT,SDCNT)=0
     53 K ^TMP("SDDPT",$J)
     54 N CRUNID S CRUNID=$O(^SDWL(409.6,"AD",ZTSK,""))
     55 S RUNDT=$P(^SDWL(409.6,CRUNID,0),"^")
     56 I SDPR=0 S SDPREV=3020831,FIRST=1 ;first run
     57 E  S SDPREV=$P(^SDWL(409.6,SDPR,0),U,4),FIRST=0 ;
     58 N SDFIN,SDPEN,SDF,SDTR S (RUNID,SDFIN,SDPEN,SDTR,SDF)=0
     59 S SDDAM=SDPREV ;creation date
     60 D NOW^%DTC S TODAY=X
     61 F  S SDDAM=$O(^DPT("ASADM",SDDAM)) Q:SDDAM=""  Q:SDDAM=TODAY!SDOUT  D
     62 .N DFN S DFN=0
     63 .F  S DFN=$O(^DPT("ASADM",SDDAM,DFN)) Q:+DFN'=DFN!SDOUT  D
     64 ..N SDADT S SDADT=0 ;appt date/time
     65 ..S SDADT=0
     66 ..F  S SDADT=$O(^DPT("ASADM",SDDAM,DFN,SDADT)) Q:+SDADT'=SDADT!SDOUT  D
     67 ...I SDDAM'=$$GET1^DIQ(2.98,SDADT_","_DFN_",",20,"I") Q  ;compare creation dates
     68 ...; Check for 'stop task' request
     69 ...S SDCNT=SDCNT+1 I SDCNT#500=0 S SDOUT=$$S^%ZTLOAD I SDOUT D  N SDBCID,SDMCID,SDSTOP D SNDS19^SDRPA07(ZTSK,.SDBCID,.SDMCID) S SDSTOP=1 D MSGT^SDRPA03(CRUNID,SDPEN,SDFIN,,SDSTOP) K ^TMP("SDDPT",$J) Q
     70 ....N DA,DIE,DR,SDD,SDLAST D
     71 ....S SDLAST=$O(^SDWL(409.6,CRUNID,1,"B"),-1) S SDD=$P(^SDWL(409.6,CRUNID,1,SDLAST,0),U,7)-1
     72 ....S DA=CRUNID,DIE=409.6,DR="1.2///"_SDD D ^DIE
     73 ...N SDCL,SDSTAT,SDSTTY
     74 ...S SDCL=$$GET1^DIQ(2.98,SDADT_","_DFN_",",.01,"I")
     75 ...Q:SDCL=""  ; If this happens, there's something wrong. Do we need to handle exceptions like this?
     76 ...;
     77 ...; Check status.
     78 ...; If the appointment is finalized and it is the first run, do not send if the date appoinment made is before Sep 1, 2003
     79 ...; If it is not the first run, send but don't create a pending file
     80 ...; Otherwise add to pending file.
     81 ...D NOW^%DTC N STODAY S STODAY=X
     82 ...S SDSTAT=$$STATUS^SDRPA05(DFN,SDADT,SDCL,STODAY,1)
     83 ...I $P(SDSTAT,"^")=0 Q
     84 ...N SDCLL S SDCLL=$P(SDSTAT,U,6) I SDCLL'="" S SDCL=SDCLL ;assign a new clinic if from matching non count with encounter
     85 ...S SDSTTY=$P(SDSTAT,U,2),SD6A=$P(SDSTAT,U,3),SD8A=$P(SDSTAT,U,4)
     86 ...I SDSTTY="F" Q:'$$GT90DAYS(SDDAM,3030831)  ; pending and final from 09/01/2003, previously 90 days
     87 ...I SDSTTY="F",SD6A="NM",SD8A="NC" Q  ; skip non-count if not matching count and scheduled date already expired
     88 ...N SDCOA,SDMSHA S SDCOA=$P(SDSTAT,U,5) S SDMSHA=$P(SDSTAT,U)
     89 ...N SDCE Q:'$$DPT^SDRPA08(DFN,.SDCE)  ; Create demographic node of ^TMP file. Quit if this failed.
     90 ...N DIC,DA,X,SDRET D
     91 ....N SDRET S SDRET=$S(SDSTTY="F":"N",1:"Y")
     92 ....S DIC="^SDWL(409.6,"_CRUNID_",1,",DA(1)=CRUNID,DIC("P")=409.69,DIC(0)="X"
     93 ....K DO S X=DFN D FILE^DICN
     94 ....S DA=+Y,DIE=DIC,DR="1///"_SDADT_";4///"_SDRET_";5///"_SD6A_";6///"_SDDAM_";8///"_SD8A_";9////"_SDCL D ^DIE
     95 ....Q
     96 ...D APPT^SDRPA08(DFN,SDADT,$$DTCONV^SDRPA08(SDDAM),SDCL,SDSTAT)
     97 ...S SDFF=$P(SDSTAT,"^",4) D STAT(SDSTTY,SDFF,.SDFIN,.SDPEN,.SDF)
     98 ...S SDTR=SDTR+1 I SDTR=5000 D SNDS19^SDRPA07(ZTSK,.SDBCID,.SDMCID) K ^TMP("SDDPT",$J) S SDTR=0
     99 Q:SDOUT
     100 N SDD S SDD=$O(^DPT("ASADM",TODAY),-1) ;enter the last scanned day
     101 S DA=CRUNID,DIE=409.6,DR="1.2///"_SDD D ^DIE
     102 ; scan the previous runs
     103 S RUNID=0
     104 F  S RUNID=$O(^SDWL(409.6,RUNID)) Q:+RUNID=CRUNID!SDOUT  D
     105 .N APPTID,SDADT,REC
     106 .S APPTID=0
     107 .;scanning only appointments that were sent as 'pending'
     108 .F  S APPTID=$O(^SDWL(409.6,"AE","Y",RUNID,APPTID)) Q:APPTID=""!SDOUT  S REC=$G(^SDWL(409.6,RUNID,1,APPTID,0)) D
     109 ..IF REC="" K ^SDWL(409.6,"AE","Y",RUNID,APPTID) Q  ;anticipate
     110 ..S DFN=$P(REC,"^"),SDADT=$P(REC,"^",2)
     111 ..; Check for 'stop task'
     112 ..S SDCNT=SDCNT+1 I SDCNT#500=0 S SDOUT=$$S^%ZTLOAD I SDOUT N SDBCID,SDMCID,SDSTOP D SNDS19^SDRPA07(ZTSK,.SDBCID,.SDMCID) S SDSTOP=1 D MSGT^SDRPA03(CRUNID,SDPEN,SDFIN,,SDSTOP) K ^TMP("SDDPT",$J) Q  ;
     113 ..N SDCL,SDCLO,SDCE,SDSTAT,SDREJ,SDDAM,SDDAMO
     114 ..S SDCLO=$P(REC,"^",10)
     115 ..S SDREJ=$P(REC,"^",8),SDDAMO=$P(REC,"^",7) ;esw
     116 ..I SDDAMO="" D
     117 ...N SDD S SDD=9999999 F  S SDD=$O(^DPT("ASADM",SDD),-1) Q:SDD'>0  I $D(^DPT("ASADM",SDD,DFN,SDADT)) S SDDAMO=SDD Q
     118 ..Q:SDDAMO=""  ;cannot determine what was original creation date
     119 ..;evaluate if the same creation date
     120 ..S SDDAM=$$GET1^DIQ(2.98,SDADT_","_DFN_",",20,"I")
     121 ..S SDCL=$$GET1^DIQ(2.98,SDADT_","_DFN_",",.01,"I")
     122 ..Q:SDCL=""  ;
     123 ..I SDCLO="" S SDCLO=SDCL
     124 ..I SDDAM'?7N!(SDDAM'>3020831) S SDDAM=SDDAMO ; need to finalize the previously sent
     125 ..; Check status. If it is a termination, continue.
     126 ..Q:$D(^TMP("SDDPT",$J,DFN,SDADT))  ; overridden to be process next time
     127 ..;anothercross reference entry will be created; do not need to quit
     128 ..;Q:$D(^SDWL(409.6,"AC",DFN,SDADT,+$G(CRUNID)))  ;see above
     129 ..S SDSTAT=""
     130 ..I SDDAM'=SDDAMO!(SDCL'=SDCLO) D
     131 ...; create CT status; the current SDADT has different creation date
     132 ...S SDSTAT="S15"_U_"F"_U_"CT"_U_U_U_U_U S SDDAM=SDDAMO,SDCL=SDCLO
     133 ..I SDSTAT="" D NOW^%DTC N SDTODAY S SDTODAY=X S SDSTAT=$$STATUS^SDRPA05(DFN,SDADT,SDCL,SDTODAY,0)
     134 ..I $P(SDSTAT,"^")=0 Q
     135 ..N SDCOA,SDMSHA S SDCOA=$P(SDSTAT,U,5) S SDMSHA=$P(SDSTAT,U),SD6A=$P(SDSTAT,U,3),SD8A=$P(SDSTAT,U,4)
     136 ..N SDCLL S SDCLL=$P(SDSTAT,U,6) I SDCLL'="" S SDCL=SDCLL
     137 ..S SDSTTY=$P(SDSTAT,U,2)
     138 ..I SDSTTY="P"&(SDREJ="") Q  ;do not send in pending status if not rejected ;esw
     139 ..N SDCE Q:'$$DPT^SDRPA08(DFN,.SDCE)  ; Create demographic node of ^TMP file. Quit if this failed.
     140 ..N DIC,DA,X D
     141 ...N SDRET S SDRET=$S(SDSTTY="F":"N",1:"Y")
     142 ...S DIC="^SDWL(409.6,"_CRUNID_",1,",DA(1)=CRUNID,DIC("P")=409.69,DIC(0)="X"
     143 ...K DO S X=DFN D FILE^DICN
     144 ...S DA=+Y,DIE=DIC,DA=+Y,DR="1///"_SDADT_";4///"_SDRET_";5///"_SD6A_";6///"_SDDAM_";8///"_SD8A_";9////"_SDCL D ^DIE
     145 ...Q
     146 ..N DIC,DA D
     147 ...; not rejected can be sent only as 'S'- sent as final
     148 ...N SDRET S SDRET=$S(SDREJ'="":"R",1:"S") ; indicates that it was: R - sent as rejected, S - sent as final
     149 ...S DIC="^SDWL(409.6,"_RUNID_",1,",DA(1)=RUNID
     150 ...S DA=APPTID,DIE=DIC,DR="4////"_SDRET D ^DIE
     151 ...Q
     152 ..D APPT^SDRPA08(DFN,SDADT,$$DTCONV^SDRPA08(SDDAM),SDCL,SDSTAT)
     153 ..S SDFF=$P(SDSTAT,"^",4) D STAT(SDSTTY,SDFF,.SDFIN,.SDPEN,.SDF)
     154 ..S SDTR=SDTR+1 I SDTR=5000 D SNDS19^SDRPA07(ZTSK,.SDBCID,.SDMCID) K ^TMP("SDDPT",$J) S SDTR=0
     155 ..Q
     156 .Q
     157 Q:SDOUT
     158 I $O(^TMP("SDDPT",$J,"")) D SNDS19^SDRPA07(ZTSK,.SDBCID,.SDMCID)
     159 K ^TMP("SDDPT",$J)
     160 D MSGT^SDRPA03(CRUNID,SDPEN,SDFIN)
     161 Q
     162STMES ;generate start message
     163 N SDS,SD870,SD87
     164 S SD870=$O(^HLCS(870,"B","SD-PAIT",""))
     165 N ARRAY D GETS^DIQ(870,SD870_",",4,"I","ARRAY")
     166 N SD87 S SD87=SD870_","
     167 S SDSTAT=ARRAY(870,SD87,4,"I")
     168 D NOW^%DTC
     169 N SDDT,SDST S SDDT=%
     170 S SDST=$P($$SITE^VASITE(),"^",3)
     171 N SDAMX,XMSUB,CMY,XMTEXT,XMDUZ
     172 S XMSUB=$G(SDST)_" - PAIT START JOB"
     173 S XMY("G.SD-PAIT")=""
     174 S XMY("S.SD-PAIT-SERVER@FORUM.VA.GOV")=""
     175 S XMTEXT="SDAMX("
     176 S XMDUZ="POSTMASTER"
     177 S SDAMX(1)="The PAIT job has started - TASK #: "_ZTSK
     178 S SDAMX(2)="Site   Started       SD-PAIT status    Task #"
     179 S SDAMX(3)=SDST_"  |"_SDDT_" |"_SDSTAT_"    |"_ZTSK
     180 ;
     181 I SDSTAT="Shutdown" S XMY("VHACIONHD@MED.VA.GOV")="" D
     182 .S SDAMX(4)=" Please start NOIS call for station "_SDST
     183 .S SDAMX(5)="SD-PAIT Logical Link has to be started."
     184 .S SDAMX(6)=""
     185 D ^XMD
     186 Q
     187 ;
     188GT90DAYS(X1,X2) ; Date is older than Sep 1st 2003, see specs.
     189 ; X1 - creation date. More efficient to have it set at the top instead of every time this subroutine is called.
     190 ; X2 - comparison date, now sent as Sep 1 2003, both in Vista format cyymmdd
     191 D ^%DTC
     192 Q X>0  ;
     193STAT(SDSTTY,SDFF,SDFIN,SDPEN,SDF) ;summarize pending and finals
     194 I SDSTTY="F" S SDFIN=SDFIN+1 Q
     195 I SDSTTY="P" S SDPEN=SDPEN+1 I SDFF="F" S SDF=SDF+1
     196 Q

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDRPA04.m

    r613 r623  
    1 SDRPA04 ;BP-OIFO/ESW - SDRPA00 continuation PAIT - REPAIR  ; 11/2/04 11:47am  ; 5/31/07 5:29pm
    2         ;;5.3;Scheduling;**376,491**;Aug 13, 1993;Build 53
    3         ;SD/491 - not to error out while repairing with acks having received
    4         Q
    5 MSGT(CRUNID,SDPEN,SDFIN,SDTOT,SDSTOP)   ;create completion messages
    6         ;CRUNID - current run number
    7         ;SDPEN  - pendings
    8         ;SDFIN  - finals
    9         ;SDTOT  - total
    10         ;SDSTOP - task stop flag
    11         N SDB,SDTRF
    12         I '$D(SDTOT) S SDTOT=SDPEN+SDFIN
    13         N SFF S SFF=0
    14         I +SDTOT=0 S (SDPEN,SDFIN)=0,SFF=1
    15         I '$D(SDPEN),'$D(SDFIN) S (SDPEN,SDFIN)="undetermined",SFF=1
    16         N SDB,SDTRF
    17         S SDB=SDTOT\5000 I SDTOT-(5000*SDB)>0 S SDB=SDB+1 ;# of batches
    18         N NOW S NOW=$$NOW^XLFDT S SDTRF=$$FMTE^XLFDT(NOW,2),SDTRF=$P(SDTRF,":",1,2)
    19         N DA,DIE,DR D
    20         .S DA=CRUNID,DIE=409.6,DR="1.3///"_SDTOT_";1.4///"_SDB_";1.5///"_NOW D ^DIE
    21         D CLEAN(CRUNID)
    22         N SDS,SDSTAT,SDIP,SDAR,SDAP,SDMT,SDMS,SD870
    23         ;SDS - STATION #
    24         ;SDSTAT - SD-PAIT STATUS
    25         ;SDAIP  - IP ADDRESS
    26         ;SDAR   - COMMIT ACK RECEIVED
    27         ;SDAP   - COMMIT ACK PROCESSED
    28         ;SDMT   - MESSAGES (BATCHES) TO SEND
    29         ;SDMS   - MESSAGES (BATCHES) SENT
    30         S SD870=$O(^HLCS(870,"B","SD-PAIT",""))
    31         N ARRAY D GETS^DIQ(870,SD870_",","4;5;6;7;8;400.01","I","ARRAY")
    32         N SD87 S SD87=SD870_","
    33         S SDSTAT=ARRAY(870,SD87,4,"I")
    34         S SDAR=ARRAY(870,SD87,5,"I")
    35         S SDAP=ARRAY(870,SD87,6,"I")
    36         S SDMS=ARRAY(870,SD87,7,"I")
    37         S SDMT=ARRAY(870,SD87,8,"I")
    38         S SDIP=ARRAY(870,SD87,400.01,"I")
    39         S SDS=$P($$SITE^VASITE(),"^",3)
    40         ;S SDS=$E($O(^SDWL(409.6,"AMSG","")),1,3)
    41         N SDBT,STSK,SDSL ; Starting and Last scanned date
    42         S SDBT=$P(^SDWL(409.6,CRUNID,0),U),SDSL=$P(^SDWL(409.6,CRUNID,0),U,4)
    43         S STSK=$P(^SDWL(409.6,CRUNID,0),U,2)
    44         S SDBT=$$FMTE^XLFDT(SDBT,2),SDSL=$$FMTE^XLFDT(SDSL,2)
    45 MSG     ;send mail message
    46         N SDAMX,XMSUB,XMY,XMTEXT,XMDUZ
    47         S XMSUB=$G(SDS)_" - PAIT BACKGROUND JOB"
    48         S XMY("G.SD-PAIT")=""
    49         S XMY("S.SD-PAIT-SERVER@FORUM.VA.GOV")=""
    50         S XMTEXT="SDAMX("
    51         S DUZ=""
    52         S XMDUZ="POSTMASTER"
    53         S SDAMX(1)=""
    54         S SDAMX(2)="The PAIT job has completed - TASK #: "_STSK_" Log #: "_CRUNID_" on "_SDTRF
    55         S SDAMX(3)="Started: "_SDBT_"                        Last Scanned: "_SDSL
    56         S SDAMX(4)="Pending appointments: "_$J(SDPEN,10)
    57         S SDAMX(5)="Final appointments:   "_$J(SDFIN,10)
    58         S SDAMX(6)="                       ----------"
    59         S SDAMX(7)="Total appointments:   "_$J(SDTOT,10)_"   Number of batches: "_SDB
    60         S SDAMX(8)=""
    61         S SDAMX(9)="Fac Log Bch Appt #  Date finished  IP Address  Gen  Sent Com R Com P  Status"
    62         S SDAMX(10)="-----------------------------------------------------------------------"
    63         S SDAMX(11)=SDS_"|"_$J(CRUNID,3)_"|"_$J(SDB,3)_"|"_$J(SDTOT,7)_"|"_SDTRF_"|"_$J(SDIP,11)_"|"_$J(SDMT,4)_"|"_$J(SDMS,4)_"|"_$J(SDAR,4)_"|"_$J(SDAP,4)_"| "_SDSTAT
    64         S SDAMX(12)=""
    65         I $G(SDSTOP) S XMY("VHACIONHD@MED.VA.GOV")="" D  D ^XMD Q
    66         .S SDAMX(13)="WARNING: TASK STOPPED BY USER, NEEDS TO BE RESTARTED."
    67         .S SDAMX(14)="Initiate a Remedy ticket TO FOLLOW UP."
    68         I 'SFF I SDMT>0!(SDB=0) D  D ^XMD K ^TMP("SDDPT",$J) Q
    69         .I (SDMT-SDMS)=0 D  Q
    70         ..S SDAMX(13)="SUCCESS: Transmission completed."
    71         .I (SDMT-SDMS)<SDB!(SDB=1&(SDMT-SDMS)'<SDB)&(SDSTAT'["Shutdown") D  Q
    72         ..S SDAMX(13)="WARNING: "_(SDMT-SDMS)_" out of "_SDB_" batches still have to be transmitted,"
    73         ..S SDAMX(14)="please verify with the HL7 System Monitor."
    74         .S XMY("VHACIONHD@MED.VA.GOV")=""
    75         .I SDB>0 I (SDMT-SDMS)'<SDB D  Q
    76         ..S XMY("VHACIONHD@MED.VA.GOV")=""
    77         ..I SDSTAT["Shutdown" D
    78         ...S SDAMX(13)="SD-PAIT Logical Link has to be started, initiate Remedy ticket for Scheduling PAIT."
    79         ..E  S SDAMX(13)="Initiate a Remedy ticket for Interface Engine - communication problem."
    80         I SFF D  D ^XMD K ^TMP("SDDPT",$J) Q
    81         .S SDAMX(13)="WARNING!!!: Transmission of run#: "_CRUNID_" has been repaired, you may restart."
    82         .I SDB>0 I (SDMT-SDMS)'<SDB D
    83         ..S XMY("VHACIONHD@MED.VA.GOV")=""
    84         ..I SDSTAT["Shutdown" D  Q
    85         ...S SDAMX(14)="SD-PAIT Logical Link has to be started, initiate Remedy ticket for Scheduling PAIT."
    86         ..S SDAMX(14)="Initiate a Remedy ticket for Interface Engine - communication problem."
    87         Q
    88 CLEAN(CRUNID)   ;housekeeping
    89         ;clean up batches previous to current one by checking for "AE",("S" or "R") xref and
    90         ;deleting if entry in xref exists
    91         ;RUN  :  run #           (ien of multiple entry)
    92         ;V1   :  previous run #  (ien of multiple entry) 
    93         ;V2   :  ien           (ien in multiple)
    94         N V1,V2,V3,ZNODE,DIK
    95         S V1=CRUNID F  S V1=$O(^SDWL(409.6,V1),-1) Q:'V1  D
    96         .F V3="R","S" S V2=0 F  S V2=$O(^SDWL(409.6,"AE",V3,V1,V2)) Q:'V2  D
    97         ..S ZNODE=$G(^SDWL(409.6,V1,1,V2,0))
    98         ..S ^XTMP("SDRPA-"_$P(ZNODE,"^",3),0)=$$HTFM^XLFDT($H+7,1)_U_$$HTFM^XLFDT($H,1)
    99         ..S DIK="^SDWL(409.6,"_V1_",1,"
    100         ..S DA(1)=V1,DA=V2 D ^DIK
    101         ..S ^XTMP("SDRPA-"_$P(ZNODE,"^",3),"CLEAN",+$P(ZNODE,"^",4),0)=ZNODE ;diagnostics
    102         Q
    103 RPAIT(RUN)      ;
    104         ;RUN - run number - entry ^SDWL(409.6,RUN,0) to be repaired
    105         Q:+$G(RUN)'>1
    106         W !,"The repairing in progress...",!
    107         N SDE,SDEB,SDFE,SDLSD,SDRCNT,ZTSK
    108         S SDE=$G(^SDWL(409.6,RUN,0)) Q:SDE=""
    109         S ZTSK=$P(SDE,"^",2) D STAT^%ZTLOAD I ZTSK(1)=1!(ZTSK(1)=2) W !,"Task "_ZTSK_"is still active!" Q
    110         S SDEB=+$P(SDE,"^",3) ; last batch # submitted to HL7
    111         S SDRCNT=$O(^SDWL(409.6,RUN,1,999999999),-1) ;last entry
    112         I SDEB=0 S SDFE=0 S $P(^SDWL(409.6,RUN,0),U,4)=$P(^SDWL(409.6,RUN-1,0),U,4)
    113         I +SDEB>0 D
    114         .S SDFE=SDRCNT+1 F  S SDFE=$O(^SDWL(409.6,RUN,1,SDFE),-1) I $P(^SDWL(409.6,RUN,1,SDFE,0),U,3)'>SDEB&($P(^SDWL(409.6,RUN,1,SDFE,0),U,3)'="") Q  ; SD/491
    115         .N SDLSD1 S SDLSD1=$P(^SDWL(409.6,RUN,1,SDFE,0),U,7) ;retrieve the last used creation date of HL7 created
    116         .N SDLSD2 S SDLSD2=$P($G(^SDWL(409.6,RUN,1,SDFE+1,0)),U,7)
    117         .S SDLSD=$P(SDE,U,4) ; last scanned date
    118         .I SDLSD="" D
    119         ..S $P(^SDWL(409.6,RUN,0),U,4)=$S(SDLSD2>SDLSD1:SDLSD1,1:SDLSD1-1)
    120         .E  S $P(^SDWL(409.6,RUN,0),U,4)=SDLSD-1
    121         N SDS,DIK F SDS=SDFE+1:1:SDRCNT I $D(^SDWL(409.6,RUN,1,SDS,0)) D EVAL(RUN,SDS) S DIK="^SDWL(409.6,"_RUN_",1,",DA(1)=RUN,DA=SDS D ^DIK
    122         S SDB=+$P($G(^SDWL(409.6,RUN,2,0)),U,3)
    123         S NOW=$$NOW^XLFDT,SDFE=5000*SDB
    124         S $P(^SDWL(409.6,RUN,0),U,5)=SDFE
    125         S $P(^SDWL(409.6,RUN,0),U,6)=SDB
    126         S $P(^SDWL(409.6,RUN,0),U,7)=NOW
    127         D MSGT(RUN,,,SDFE)
    128         W !!,"The last run number has been repaired, you may ONE TIME QUEUE the next one.",!
    129         Q
    130 EVAL(RUN,SDS)   ;
    131         ;evaluate if to update any 'S' or 'R' Retention Flags for
    132         ;the previous entry if exists.
    133         N SDSTR,DFN,SDDT S SDSTR=^SDWL(409.6,RUN,1,SDS,0)
    134         S DFN=+SDSTR,SDDT=$P(SDSTR,"^",2)
    135         Q:SDDT=""
    136         ;find a prior entry SDRUN
    137         N SDRUN S SDRUN=$O(^SDWL(409.6,"AC",DFN,SDDT,RUN),-1) Q:SDRUN=""
    138         N SDSQ S SDSQ=$O(^SDWL(409.6,"AC",DFN,SDDT,SDRUN,""))
    139         N SDSTRP S SDSTRP=^SDWL(409.6,SDRUN,1,SDSQ,0)
    140         N SDRET S SDRET=$P(SDSTRP,"^",5)
    141         I SDRET="S"!(SDRET="R") N DIC D
    142         .S SDRET="Y",DIC="^SDWL(409.6,"_SDRUN_",1,",DA(1)=SDRUN,DA=SDSQ,DIE=DIC,DR="4///"_SDRET D ^DIE
    143         Q
     1SDRPA04 ;BP-OIFO/ESW - PAIT - REPAIR  ; 11/2/04 11:47am
     2 ;;5.3;Scheduling;**376**;Aug 13, 1993
     3 Q
     4MSGT(CRUNID,SDPEN,SDFIN,SDTOT,SDSTOP) ;create completion messages
     5 ;CRUNID - current run number
     6 ;SDPEN  - pendings
     7 ;SDFIN  - finals
     8 ;SDTOT  - total
     9 ;SDSTOP - task stop flag
     10 N SDB,SDTRF
     11 I '$D(SDTOT) S SDTOT=SDPEN+SDFIN
     12 N SFF S SFF=0
     13 I +SDTOT=0 S (SDPEN,SDFIN)=0,SFF=1
     14 I '$D(SDPEN),'$D(SDFIN) S (SDPEN,SDFIN)="undetermined",SFF=1
     15 N SDB,SDTRF
     16 S SDB=SDTOT\5000 I SDTOT-(5000*SDB)>0 S SDB=SDB+1 ;# of batches
     17 N NOW S NOW=$$NOW^XLFDT S SDTRF=$$FMTE^XLFDT(NOW,2),SDTRF=$P(SDTRF,":",1,2)
     18 N DA,DIE,DR D
     19 .S DA=CRUNID,DIE=409.6,DR="1.3///"_SDTOT_";1.4///"_SDB_";1.5///"_NOW D ^DIE
     20 D CLEAN(CRUNID)
     21 N SDS,SDSTAT,SDIP,SDAR,SDAP,SDMT,SDMS,SD870
     22 ;SDS - STATION #
     23 ;SDSTAT - SD-PAIT STATUS
     24 ;SDAIP  - IP ADDRESS
     25 ;SDAR   - COMMIT ACK RECEIVED
     26 ;SDAP   - COMMIT ACK PROCESSED
     27 ;SDMT   - MESSAGES (BATCHES) TO SEND
     28 ;SDMS   - MESSAGES (BATCHES) SENT
     29 S SD870=$O(^HLCS(870,"B","SD-PAIT",""))
     30 N ARRAY D GETS^DIQ(870,SD870_",","4;5;6;7;8;400.01","I","ARRAY")
     31 N SD87 S SD87=SD870_","
     32 S SDSTAT=ARRAY(870,SD87,4,"I")
     33 S SDAR=ARRAY(870,SD87,5,"I")
     34 S SDAP=ARRAY(870,SD87,6,"I")
     35 S SDMS=ARRAY(870,SD87,7,"I")
     36 S SDMT=ARRAY(870,SD87,8,"I")
     37 S SDIP=ARRAY(870,SD87,400.01,"I")
     38 S SDS=$P($$SITE^VASITE(),"^",3)
     39 ;S SDS=$E($O(^SDWL(409.6,"AMSG","")),1,3)
     40 N SDBT,STSK,SDSL ; Starting and Last scanned date
     41 S SDBT=$P(^SDWL(409.6,CRUNID,0),U),SDSL=$P(^SDWL(409.6,CRUNID,0),U,4)
     42 S STSK=$P(^SDWL(409.6,CRUNID,0),U,2)
     43 S SDBT=$$FMTE^XLFDT(SDBT,2),SDSL=$$FMTE^XLFDT(SDSL,2)
     44MSG ;send mail message
     45 N SDAMX,XMSUB,XMY,XMTEXT,XMDUZ
     46 S XMSUB=$G(SDS)_" - PAIT BACKGROUND JOB"
     47 S XMY("G.SD-PAIT")=""
     48 S XMY("S.SD-PAIT-SERVER@FORUM.VA.GOV")=""
     49 S XMTEXT="SDAMX("
     50 S DUZ=""
     51 S XMDUZ="POSTMASTER"
     52 S SDAMX(1)=""
     53 S SDAMX(2)="The PAIT job has completed - TASK #: "_STSK_" Log #: "_CRUNID_" on "_SDTRF
     54 S SDAMX(3)="Started: "_SDBT_"                        Last Scanned: "_SDSL
     55 S SDAMX(4)="Pending appointments: "_$J(SDPEN,10)
     56 S SDAMX(5)="Final appointments:   "_$J(SDFIN,10)
     57 S SDAMX(6)="                       ----------"
     58 S SDAMX(7)="Total appointments:   "_$J(SDTOT,10)_"   Number of batches: "_SDB
     59 S SDAMX(8)=""
     60 S SDAMX(9)="Fac Log Bch Appt #  Date finished  IP Address  Gen  Sent Com R Com P  Status"
     61 S SDAMX(10)="-----------------------------------------------------------------------"
     62 S SDAMX(11)=SDS_"|"_$J(CRUNID,3)_"|"_$J(SDB,3)_"|"_$J(SDTOT,7)_"|"_SDTRF_"|"_$J(SDIP,11)_"|"_$J(SDMT,4)_"|"_$J(SDMS,4)_"|"_$J(SDAR,4)_"|"_$J(SDAP,4)_"| "_SDSTAT
     63 S SDAMX(12)=""
     64 I $G(SDSTOP) S XMY("VHACIONHD@MED.VA.GOV")="" D  D ^XMD Q
     65 .S SDAMX(13)="WARNING: TASK STOPPED BY USER, NEEDS TO BE RESTARTED."
     66 .S SDAMX(14)="INITIATE a NOIS TO FOLLOW UP."
     67 I 'SFF I SDMT>0!(SDB=0) D  D ^XMD Q
     68 .I (SDMT-SDMS)=0 D  Q
     69 ..S SDAMX(13)="SUCCESS: Transmission completed."
     70 .I (SDMT-SDMS)<SDB D  Q
     71 ..S SDAMX(13)="WARNING: "_(SDMT-SDMS)_" out of "_SDB_" batches still have to be transmitted,"
     72 ..S SDAMX(14)="please verify with the HL7 System Monitor."
     73 .S XMY("VHACIONHD@MED.VA.GOV")=""
     74 .I SDMT-SDMS'<SDB D  Q
     75 ..S XMY("VHACIONHD@MED.VA.GOV")=""
     76 ..I SDSTAT["Shutdown" S SDAMX(13)="SD-PAIT Logical Link has to be started!"
     77 ..E  S SDAMX(13)="Initiate a NOIS for VistA Interface Engine - communication problem."
     78 I SFF S XMY("VHACIONHD@MED.VA.GOV")="" D  D ^XMD Q
     79 .S SDAMX(13)="WARNING!!!: Transmission of run#: "_CRUNID_" has been repaired."
     80 .S SDAMX(14)="Please create a NOIS to verify if the problem has been addressed."
     81 .I SDB>0 I (SDMT-SDMS)'<SDB D
     82 ..S SDAMX(15)="WARNING!!!: Transmission communication problem, please review."
     83 ;D ^XMD
     84 K ^TMP("SDDPT",$J)
     85 Q
     86CLEAN(CRUNID) ;housekeeping
     87 ;clean up batches previous to current one by checking for "AE",("S" or "R") xref and
     88 ;deleting if entry in xref exists
     89 ;RUN  :  run #           (ien of multiple entry)
     90 ;V1   :  previous run #  (ien of multiple entry) 
     91 ;V2   :  ien           (ien in multiple)
     92 N V1,V2,V3,ZNODE,DIK
     93 S V1=CRUNID F  S V1=$O(^SDWL(409.6,V1),-1) Q:'V1  D
     94 .F V3="R","S" S V2=0 F  S V2=$O(^SDWL(409.6,"AE",V3,V1,V2)) Q:'V2  D
     95 ..S ZNODE=$G(^SDWL(409.6,V1,1,V2,0))
     96 ..S ^XTMP("SDRPA-"_$P(ZNODE,"^",3),0)=$$HTFM^XLFDT($H+7,1)_U_$$HTFM^XLFDT($H,1)
     97 ..S DIK="^SDWL(409.6,"_V1_",1,"
     98 ..S DA(1)=V1,DA=V2 D ^DIK
     99 ..S ^XTMP("SDRPA-"_$P(ZNODE,"^",3),"CLEAN",+$P(ZNODE,"^",4),0)=ZNODE ;diagnostics
     100 Q
     101RPAIT(RUN) ;
     102 ;RUN - run number - entry ^SDWL(409.6,RUN,0) to be repaired
     103 Q:+$G(RUN)'>1
     104 W !,"The repairing in progress...",!
     105 N SDE,SDEB,SDFE,SDLSD,SDRCNT,ZTSK
     106 S SDE=$G(^SDWL(409.6,RUN,0)) Q:SDE=""
     107 S ZTSK=$P(SDE,"^",2) D STAT^%ZTLOAD I ZTSK(1)=1!(ZTSK(1)=2) W !,"Task "_ZTSK_"is still active!" Q
     108 S SDEB=+$P(SDE,"^",3) ; last batch # submitted to HL7
     109 S SDRCNT=$O(^SDWL(409.6,RUN,1,999999999),-1) ;last entry
     110 I SDEB=0 S SDFE=0 S $P(^SDWL(409.6,RUN,0),U,4)=$P(^SDWL(409.6,RUN-1,0),U,4)
     111 I +SDEB>0 D
     112 .S SDFE=SDRCNT+1 F  S SDFE=$O(^SDWL(409.6,RUN,1,SDFE),-1) I $P(^SDWL(409.6,RUN,1,SDFE,0),U,3)=SDEB Q  ; last accepted entry
     113 .N SDLSD1 S SDLSD1=$P(^SDWL(409.6,RUN,1,SDFE,0),U,7) ;retrieve the last used creation date of HL7 created
     114 .N SDLSD2 S SDLSD2=$P($G(^SDWL(409.6,RUN,1,SDFE+1,0)),U,7)
     115 .S SDLSD=$P(SDE,U,4) ; last scanned date
     116 .I SDLSD="" D
     117 ..S $P(^SDWL(409.6,RUN,0),U,4)=$S(SDLSD2>SDLSD1:SDLSD1,1:SDLSD1-1)
     118 .E  S $P(^SDWL(409.6,RUN,0),U,4)=SDLSD-1
     119 N SDS,DIK F SDS=SDFE+1:1:SDRCNT D EVAL(RUN,SDS) S DIK="^SDWL(409.6,"_RUN_",1,",DA(1)=RUN,DA=SDS D ^DIK
     120 S SDB=SDFE\5000 I SDFE-(5000*SDB)>0 S SDB=SDB+1
     121 S NOW=$$NOW^XLFDT
     122 S $P(^SDWL(409.6,RUN,0),U,5)=SDFE
     123 S $P(^SDWL(409.6,RUN,0),U,6)=SDB
     124 S $P(^SDWL(409.6,RUN,0),U,7)=NOW
     125 D MSGT(RUN,,,SDFE)
     126 W !!,"The last run number has been repaired, you may ONE TIME QUEUE the next one.",!
     127 Q
     128EVAL(RUN,SDS) ;
     129 ;evaluate if to update any 'S' or 'R' Retention Flags for
     130 ;the previous entry if exists.
     131 N SDSTR,DFN,SDDT S SDSTR=^SDWL(409.6,RUN,1,SDS,0)
     132 S DFN=+SDSTR,SDDT=$P(SDSTR,"^",2)
     133 ;find a prior entry SDRUN
     134 N SDRUN S SDRUN=$O(^SDWL(409.6,"AC",DFN,SDDT,RUN),-1) Q:SDRUN=""
     135 N SDSQ S SDSQ=$O(^SDWL(409.6,"AC",DFN,SDDT,SDRUN,""))
     136 N SDSTRP S SDSTRP=^SDWL(409.6,SDRUN,1,SDSQ,0)
     137 N SDRET S SDRET=$P(SDSTRP,"^",5)
     138 I SDRET="S"!(SDRET="R") N DIC D
     139 .S SDRET="Y",DIC="^SDWL(409.6,"_SDRUN_",1,",DA(1)=SDRUN,DA=SDSQ,DIE=DIC,DR="4///"_SDRET D ^DIE
     140 Q

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDRPA05.m

    r613 r623  
    1 SDRPA05 ;BP-OIFO/ESW - Evaluate appointment status for HL7  ; 9/10/04 9:34am
    2         ;;5.3;Scheduling;**290,333,349,376,491**;AUG 13, 2003;Build 53
    3         ;Evaluation of the appointment status is done from the computed field to match the displayed/printed status in the appointment management
    4         ;SD/491 - MODIFIED $$SCHEDULE to cut off appointments considered as rescheduled by with the scheduled date<2250000
    5         Q
    6         ;
    7 STATUS(DFN,SDADT,SDCL,TODAY,SFD)        ;
    8         ;Input:
    9         ;      SDADT - Appt date/time
    10         ;      SDCL  - Clinic IEN
    11         ;      SFD:   - 0 - if called from scanning previous runs - update
    12         ;             - 1 - if called from scanning 2.98
    13         ;Output:
    14         ;       SDSTAT=SDMSH_U_SD25_U_SD6_U_SD8_U_SDCO_U_SDCLL_U_SD8RD
    15         ;        where:
    16         ;              SDMSH -HL7 segment
    17         ;              SD25  - Filler Status:
    18         ;                                    P - Pending
    19         ;                                    F - Final
    20         ;              SD6   - Event Reason
    21         ;              SD8   - Appt Type
    22         ;              SD8RD - rescheduled date/time if SD8="RS"
    23         ;              SDCO  - check out date
    24         ;              SDCLL - clinic IEN from matching encounter
    25         ;
    26         N SD0,SDST,SD6,SD8,SD25,SDMSH,SDCO,SDSTAT,SD8S,SD8RD
    27         S SDST=$$GET1^DIQ(2.98,SDADT_","_DFN_",",3,"I")
    28         I SDST'="" I SDST'="NT"&(SDST'="I") D  Q SDSTAT
    29         .S SD25="F",SDCO="",SD8RD=""
    30         .I SDST="C" S SD6="CC",SD8="",SDMSH="S15" D  ;cancel by clinic
    31         ..S SD8S=$$SCHEDULE(DFN,SDCL,SDADT),SD8=$P(SD8S,U),SD8RD=$P(SD8S,U,2)
    32         .I SDST="CA" S SD6="CC",SD8="ABK",SDMSH="S15" ;cancel bt clinic and auto rebook
    33         .I SDST="PC" S SD6="CP",SD8="",SDMSH="S15" D  ; cancel by patient
    34         ..S SD8S=$$SCHEDULE(DFN,SDCL,SDADT),SD8=$P(SD8S,U),SD8RD=$P(SD8S,U,2)
    35         .I SDST="PCA" S SD6="CP",SD8="ABK",SDMSH="S15" ;cancel by patient and auto rebook
    36         .I SDST="NA" S SD6="NS",SD8="ABK",SDMSH="S26" ;no show and auto rebook
    37         .I SDST="N" S SD6="NS",SD8="",SDMSH="S26" ;no show
    38         .;evaluate 'non-count'
    39         .I $P($G(^SC(SDCL,0)),U,17)="Y" D
    40         ..I SD8="" S SD8="NC" Q
    41         ..I SD8="RS" S SD8="RSN"
    42         .;
    43         .S SDSTAT=SDMSH_U_SD25_U_SD6_U_SD8_U_SDCO_U_U_SD8RD
    44         ;process all others
    45         S SD0=^DPT(DFN,"S",SDADT,0)
    46         ; check out from OUTPAT ENCOUNTER
    47         ;N SCE S SCE=$P(SD0,"^",20) S SDCO="" I SCE>0 S SDCO=$P(^SCE(SCE,0),"^",7)
    48         N SCE S SCE=$P(SD0,"^",20) S SDCO="" I SCE>0,$D(^SCE(SCE,0)) S SDCO=$P(^SCE(SCE,0),"^",7)
    49         N SDSTATX,SDX3
    50         S SDSTATX=$$STATUS^SDAM1(DFN,SDADT,SDCL,SD0) ;call to compute the status (VistA)
    51         ;SDSTATX=Appt status IFN in 409.63 ; status name ; print status ; check in ; check out
    52         I SDCO="" S SDCO=$P(SDSTATX,";",5) ; check out from clinic if NULL
    53         I SDCO'=""&(+SDSTATX'=12) D  Q SDSTAT
    54         .S SD6="CO",SD25="F",SD8="",SD8RD="",SDMSH=$S(SFD=0:"S14",1:"S12")
    55         .I +SDSTATX=3 S SD8="AR" ; action required
    56         .I +SDSTATX=8 S SD8="I" ;inpatient
    57         .;I +SDSTATX=12 S SD8="NC" ;non-count excluded to be compared to possible encounter does not matter if check out
    58         .I +SDSTATX=2 S SD8="O" ;outpatient
    59         .S SDSTAT=SDMSH_U_SD25_U_SD6_U_SD8_U_SDCO_U_U_SD8RD
    60         I +SDSTATX=3 D  Q SDSTAT
    61         .S SD25="P",SDMSH="S12",SDCO="",SD8RD=""
    62         .I $P(SDSTATX,";",4)'="" S SD6="CI",SD8="AR" ;check in/action required
    63         .E  S SD6="",SD8="NAT",SD8RD="" ;no action taken
    64         .S SDSTAT=SDMSH_U_SD25_U_SD6_U_SD8_U_SDCO_U_U_SD8RD
    65         I +SDSTATX=8!(+SDSTATX=11) S SD25="P",SD8RD="" D  Q SDSTAT
    66         .I +SDSTATX=8 S SD6="",SD8="I",SDCO="",SDMSH="S12" ;inpatient
    67         .I +SDSTATX=11 S SD6="",SD8="F",SDCO="",SDMSH="S12" ;future
    68         .S SDSTAT=SDMSH_U_SD25_U_SD6_U_SD8_U_SDCO_U_U_SD8RD
    69         ;
    70         ;process non-count (not checked out)
    71         I +SDSTATX=12 N SDCLL S SDCLL="" D  S:SD6'="COE" SDCLL=SDCL S SDSTAT=SDMSH_U_SD25_U_SD6_U_SD8_U_SDCO_U_SDCLL Q SDSTAT
    72         .S SD6="",SD8="NC",SDCO="",SDMSH="S12",SD25="P"
    73         .I (SDADT\1)-(TODAY\1)>0 S SD6="",SD8="NCF",SD25="P" Q
    74         .N SDADTC,SDSCE,SDADTCK S SDADTC=(SDADT\1)-1+.99,SDADTCK=SDADTC+1 F  D  Q:'SDSCE!(SD6="COE")
    75         ..S SDSCE=$$EXAE^SDOE(DFN,SDADTC,SDADTCK)
    76         ..I SDSCE>1 N SDDATA D GETGEN^SDOE(SDSCE,"SDDATA") D
    77         ...N SDCL0,SDCL1,SDCL2
    78         ...S SDCLL=$P(SDDATA(0),"^",4) I $P(^SC(SDCLL,0),"^",17)="Y" D  Q
    79         ....S SDADTC=$P(^SCE(SDSCE,0),"^")+.000001 ;
    80         ...S SDCL0=$P(^SC(SDCL,0),"^",7)_$P(^SC(SDCL,0),"^",18)
    81         ...S SDCL2=$P(^SC(SDCLL,0),"^",7)_$P(^SC(SDCLL,0),"^",18)
    82         ...I SDCL0'=SDCL2 S SDADTC=$P(^SCE(SDSCE,0),"^")+.000001 Q
    83         ...; proceed if the same DSS IDs pairs
    84         ...S SDCO=$P(SDDATA(0),"^",7)
    85         ...I SDCO'="" S SD6="COE",SD25="F",SDMSH=$S(SFD=0:"S14",1:"S12") Q
    86         ...;encounter exists but not in final (chek out) status
    87         ...S SDADTC=$P(^SCE(SDSCE,0),"^")+.000001
    88         .I SD6="COE" Q
    89         .;check out by matching encounter
    90         .E  I ((TODAY\1)-(SDADT\1))>2 D   ;give 2 days to update
    91         ..S SD6="NM",SD25="F",SDMSH=$S(SFD=0:"S14",1:0) ;no match, to be skipped
    92         Q 0
    93         ;
    94 SCHEDULE(DFN,SDCL,SDADT)        ; Scheduling flag
    95         ; If the patient has another appointment created on the same day as the cancellation date of the canceled appt, and that
    96         ; appointment is created for a clinic with the same stop code then return "RS".
    97         ; If there is not another appointment made on the same day, return "".
    98         N SDCDT,SDCLN S SDCDT=$$GET1^DIQ(2.98,SDADT_","_DFN_",",15,"I") ;cancellation date
    99         Q:'SDCDT ""
    100         N SDCDTI S SDCDTI=SDCDT\1
    101         N SDRESCH S SDRESCH=""
    102         ;exclude the same appointments
    103         N SDAPDT S SDAPDT="" F  S SDAPDT=$O(^DPT("ASADM",SDCDTI,DFN,SDAPDT)) Q:SDAPDT=""  I SDAPDT>3030000 I SDAPDT'=SDADT I $D(^DPT(DFN,"S",SDAPDT)) D  Q:SDRESCH'=""
    104         .S SDCLN=+$P(^DPT(DFN,"S",SDAPDT,0),U) I $P(^SC(SDCLN,0),"^",7)=$P(^SC(SDCL,0),"^",7) S SDRESCH="RS"_"^"_SDAPDT ;compare stop code pointers
    105         S:SDRESCH="" SDRESCH="^" Q SDRESCH
     1SDRPA05 ;BP-OIFO/ESW - Evaluate appointment status for HL7  ; 9/10/04 9:34am
     2 ;;5.3;Scheduling;**290,333,349,376**;AUG 13, 2003
     3 ;Evaluation of the appointment status is done from the computed field to match the displayed/printed status in the appointment management
     4 Q
     5 ;
     6STATUS(DFN,SDADT,SDCL,TODAY,SFD) ;
     7 ;Input:
     8 ;      SDADT - Appt date/time
     9 ;      SDCL  - Clinic IEN
     10 ;      SFD:   - 0 - if called from scanning previous runs - update
     11 ;             - 1 - if called from scanning 2.98
     12 ;Output:
     13 ;       SDSTAT=SDMSH_U_SD25_U_SD6_U_SD8_U_SDCO_U_SDCLL_U_SD8RD
     14 ;        where:
     15 ;              SDMSH -HL7 segment
     16 ;              SD25  - Filler Status:
     17 ;                                    P - Pending
     18 ;                                    F - Final
     19 ;              SD6   - Event Reason
     20 ;              SD8   - Appt Type
     21 ;              SD8RD - rescheduled date/time if SD8="RS"
     22 ;              SDCO  - check out date
     23 ;              SDCLL - clinic IEN from matching encounter
     24 ;
     25 N SD0,SDST,SD6,SD8,SD25,SDMSH,SDCO,SDSTAT,SD8S,SD8RD
     26 S SDST=$$GET1^DIQ(2.98,SDADT_","_DFN_",",3,"I")
     27 I SDST'="" I SDST'="NT"&(SDST'="I") D  Q SDSTAT
     28 .S SD25="F",SDCO="",SD8RD=""
     29 .I SDST="C" S SD6="CC",SD8="",SDMSH="S15" D  ;cancel by clinic
     30 ..S SD8S=$$SCHEDULE(DFN,SDCL,SDADT),SD8=$P(SD8S,U),SD8RD=$P(SD8S,U,2)
     31 .I SDST="CA" S SD6="CC",SD8="ABK",SDMSH="S15" ;cancel bt clinic and auto rebook
     32 .I SDST="PC" S SD6="CP",SD8="",SDMSH="S15" D  ; cancel by patient
     33 ..S SD8S=$$SCHEDULE(DFN,SDCL,SDADT),SD8=$P(SD8S,U),SD8RD=$P(SD8S,U,2)
     34 .I SDST="PCA" S SD6="CP",SD8="ABK",SDMSH="S15" ;cancel by patient and auto rebook
     35 .I SDST="NA" S SD6="NS",SD8="ABK",SDMSH="S26" ;no show and auto rebook
     36 .I SDST="N" S SD6="NS",SD8="",SDMSH="S26" ;no show
     37 .;evaluate 'non-count'
     38 .I $P($G(^SC(SDCL,0)),U,17)="Y" D
     39 ..I SD8="" S SD8="NC" Q
     40 ..I SD8="RS" S SD8="RSN"
     41 .;
     42 .S SDSTAT=SDMSH_U_SD25_U_SD6_U_SD8_U_SDCO_U_U_SD8RD
     43 ;process all others
     44 S SD0=^DPT(DFN,"S",SDADT,0)
     45 ; check out from OUTPAT ENCOUNTER
     46 ;N SCE S SCE=$P(SD0,"^",20) S SDCO="" I SCE>0 S SDCO=$P(^SCE(SCE,0),"^",7)
     47 N SCE S SCE=$P(SD0,"^",20) S SDCO="" I SCE>0,$D(^SCE(SCE,0)) S SDCO=$P(^SCE(SCE,0),"^",7)
     48 N SDSTATX,SDX3
     49 S SDSTATX=$$STATUS^SDAM1(DFN,SDADT,SDCL,SD0) ;call to compute the status (VistA)
     50 ;SDSTATX=Appt status IFN in 409.63 ; status name ; print status ; check in ; check out
     51 I SDCO="" S SDCO=$P(SDSTATX,";",5) ; check out from clinic if NULL
     52 I SDCO'=""&(+SDSTATX'=12) D  Q SDSTAT
     53 .S SD6="CO",SD25="F",SD8="",SD8RD="",SDMSH=$S(SFD=0:"S14",1:"S12")
     54 .I +SDSTATX=3 S SD8="AR" ; action required
     55 .I +SDSTATX=8 S SD8="I" ;inpatient
     56 .;I +SDSTATX=12 S SD8="NC" ;non-count excluded to be compared to possible encounter does not matter if check out
     57 .I +SDSTATX=2 S SD8="O" ;outpatient
     58 .S SDSTAT=SDMSH_U_SD25_U_SD6_U_SD8_U_SDCO_U_U_SD8RD
     59 I +SDSTATX=3 D  Q SDSTAT
     60 .S SD25="P",SDMSH="S12",SDCO="",SD8RD=""
     61 .I $P(SDSTATX,";",4)'="" S SD6="CI",SD8="AR" ;check in/action required
     62 .E  S SD6="",SD8="NAT",SD8RD="" ;no action taken
     63 .S SDSTAT=SDMSH_U_SD25_U_SD6_U_SD8_U_SDCO_U_U_SD8RD
     64 I +SDSTATX=8!(+SDSTATX=11) S SD25="P",SD8RD="" D  Q SDSTAT
     65 .I +SDSTATX=8 S SD6="",SD8="I",SDCO="",SDMSH="S12" ;inpatient
     66 .I +SDSTATX=11 S SD6="",SD8="F",SDCO="",SDMSH="S12" ;future
     67 .S SDSTAT=SDMSH_U_SD25_U_SD6_U_SD8_U_SDCO_U_U_SD8RD
     68 ;
     69 ;process non-count (not checked out)
     70 I +SDSTATX=12 N SDCLL S SDCLL="" D  S:SD6'="COE" SDCLL=SDCL S SDSTAT=SDMSH_U_SD25_U_SD6_U_SD8_U_SDCO_U_SDCLL Q SDSTAT
     71 .S SD6="",SD8="NC",SDCO="",SDMSH="S12",SD25="P"
     72 .I (SDADT\1)-(TODAY\1)>0 S SD6="",SD8="NCF",SD25="P" Q
     73 .N SDADTC,SDSCE,SDADTCK S SDADTC=(SDADT\1)-1+.99,SDADTCK=SDADTC+1 F  D  Q:'SDSCE!(SD6="COE")
     74 ..S SDSCE=$$EXAE^SDOE(DFN,SDADTC,SDADTCK)
     75 ..I SDSCE>1 N SDDATA D GETGEN^SDOE(SDSCE,"SDDATA") D
     76 ...N SDCL0,SDCL1,SDCL2
     77 ...S SDCLL=$P(SDDATA(0),"^",4) I $P(^SC(SDCLL,0),"^",17)="Y" D  Q
     78 ....S SDADTC=$P(^SCE(SDSCE,0),"^")+.000001 ;
     79 ...S SDCL0=$P(^SC(SDCL,0),"^",7)_$P(^SC(SDCL,0),"^",18)
     80 ...S SDCL2=$P(^SC(SDCLL,0),"^",7)_$P(^SC(SDCLL,0),"^",18)
     81 ...I SDCL0'=SDCL2 S SDADTC=$P(^SCE(SDSCE,0),"^")+.000001 Q
     82 ...; proceed if the same DSS IDs pairs
     83 ...S SDCO=$P(SDDATA(0),"^",7)
     84 ...I SDCO'="" S SD6="COE",SD25="F",SDMSH=$S(SFD=0:"S14",1:"S12") Q
     85 ...;encounter exists but not in final (chek out) status
     86 ...S SDADTC=$P(^SCE(SDSCE,0),"^")+.000001
     87 .I SD6="COE" Q
     88 .;check out by matching encounter
     89 .E  I ((TODAY\1)-(SDADT\1))>2 D   ;give 2 days to update
     90 ..S SD6="NM",SD25="F",SDMSH=$S(SFD=0:"S14",1:0) ;no match, to be skipped
     91 Q 0
     92 ;
     93SCHEDULE(DFN,SDCL,SDADT) ; Scheduling flag
     94 ; If the patient has another appointment created on the same day as the cancellation date of the canceled appt, and that
     95 ; appointment is created for a clinic with the same stop code then return "RS".
     96 ; If there is not another appointment made on the same day, return "".
     97 N SDCDT,SDCLN S SDCDT=$$GET1^DIQ(2.98,SDADT_","_DFN_",",15,"I") ;cancellation date
     98 Q:'SDCDT ""
     99 N SDCDTI S SDCDTI=SDCDT\1
     100 N SDRESCH S SDRESCH=""
     101 ;exclude the same appointments
     102 N SDAPDT S SDAPDT="" F  S SDAPDT=$O(^DPT("ASADM",SDCDTI,DFN,SDAPDT)) Q:SDAPDT=""  I SDAPDT'=SDADT I $D(^DPT(DFN,"S",SDAPDT)) D  Q:SDRESCH'=""
     103 .S SDCLN=+$P(^DPT(DFN,"S",SDAPDT,0),U) I $P(^SC(SDCLN,0),"^",7)=$P(^SC(SDCL,0),"^",7) S SDRESCH="RS"_"^"_SDAPDT ;compare stop code pointers
     104 S:SDRESCH="" SDRESCH="^" Q SDRESCH

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDRPA06.m

    r613 r623  
    1 SDRPA06 ;bp-oifo/swo pait hl7 ack handling ; 10/31/04 3:53pm
    2         ;;5.3;Scheduling;**290,333,349,376,491**;AUG 13, 1993;Build 53
    3         ;routine called from Vista HL7 when ack messages are received in response
    4         ;to an out going HL7 message generated by protocol SC-PAIT-EVENT
    5 ACK     ;entry point from Vista HL7
    6         ;ACKDATE   :  date/time ack received
    7         ;FLDSEP    :  field separator
    8         ;CMPNTSEP  :  component separator
    9         ;REPTNSEP  :  repetition separator
    10         ;ACKCODE   :  acknowledgement code
    11         ;ERROR     :  reject reason
    12         ;BATCHID   :  batch control ID
    13         ;BATCHIDO  :  original batch control ID
    14         N ACKCODE,ACKDATE,BATCHID,BATCHIDO,CMPNTSEP,ERROR,FLDSEP,REPTNSEP,RUNIEN,SDZAP,V1
    15         ;disable automatic repair of the last run, not needed to process acks
    16         ;NHD will be notified when the completion message does not come out
    17         ;D RSTAT^SDRPA02 ;check the status of the last run
    18         K ^TMP("SDRPA06",$J)
    19         S SDZAP=0
    20         S ACKDATE=$$NOW^XLFDT()
    21         S FLDSEP=HL("FS")
    22         S CMPNTSEP=$E(HL("ECH"),1)
    23         S REPTNSEP=$E(HL("ECH"),2)
    24         S ACKCODE=$P(HLMSA,FLDSEP)
    25         S ERROR=$P(HLMSA,FLDSEP,4)
    26         S (BATCHID,BATCHIDO)=$P(HLMSA,FLDSEP,2)
    27         S RUNIEN=$$RUNIEN(BATCHIDO) Q:'RUNIEN
    28         S BATCHID=$$OURB(RUNIEN,BATCHIDO) ;convert to our batch id
    29         Q:'BATCHID  ;error needs to be handled
    30         ;S V1=$O(^SDWL(409.6,"AMSG",BATCHID,"")),RUNIEN=$O(^SDWL(409.6,"AMSG",BATCHID,V1,""))
    31         S V1=$O(^SDWL(409.6,"AMSG",BATCHID,"")) Q:V1=""
    32         Q:'$$DUP^SDRPA02(RUNIEN,BATCHIDO)  ;check for duplicate
    33         S ^XTMP("SDRPA-"_BATCHID,0)=$$FMADD^XLFDT($$DT^XLFDT(),3)_"^"_$$DT^XLFDT() ;set xtmp global for diagnostics
    34         I $E(ACKCODE,1,2)="AR" D AR(BATCHID,BATCHIDO),MSG(BATCHIDO,3,RUNIEN,BATCHID) Q  ;whole batch rejection
    35         ;Q:($E(ACKCODE,1,2)'="AA")  ;quit if not a application ack
    36         ;will only be 2 ACKCODEs AA and AE so don't have to screen anymore
    37         F  X HLNEXT Q:(HLQUIT'>0)  D  ;start looping the msg text
    38         . Q:($E(HLNODE,1,3)'="MSA")  ;skip if not a MSA segment
    39         . I $P(HLNODE,FLDSEP,2)="AE" D  ;it's an error
    40         .. Q:($P($P(HLNODE,FLDSEP,3),"-",2))=""  ;no message number
    41         .. S ^TMP("SDRPA06",$J,+$P($P(HLNODE,FLDSEP,3),"-",2))=+$P(HLNODE,"^",4) ;set xref with message #
    42         I '$D(^TMP("SDRPA06",$J)) D AA(BATCHID,BATCHIDO),MSG(BATCHIDO,2,RUNIEN,BATCHID) Q  ;whole batch accept
    43         D AAAR(BATCHID,BATCHIDO),MSG(BATCHIDO,1,RUNIEN,BATCHID) ;batch accept with errors   
    44         Q
    45 AR(BATCH,BATCHIDO)      ;whole batch rejection
    46         ;BATCH    :  originating batch number
    47         ;BATCHIDO :  original batch number from HL7 ACK
    48         ;V1       :  sequence #  (individual message number in batch)
    49         ;V2       :  run #       (ien of multiple entry)
    50         ;V3       :  ien         (ien in patient multiple)
    51         ;V4       :  ien         (ien batch tracking multiple)
    52         Q:($G(BATCH)="")
    53         N DA,DIE,DR,V1,V2,V3,V4,ZNODE
    54         S V1=0
    55         F  S V1=$O(^SDWL(409.6,"AMSG",BATCH,V1)) Q:'V1  D
    56         . S V2=$O(^SDWL(409.6,"AMSG",BATCH,V1,"")) Q:'V2
    57         . ;batch tracking enhancement
    58         . S V4=$O(^SDWL(409.6,V2,2,"B",BATCHIDO,"")) Q:'V4  D
    59         .. S DA=V4,DA(1)=V2,DIE="^SDWL(409.6,"_V2_",2,",DR=".04///"_$$NOW^XLFDT_";.05///"_ACKCODE
    60         .. D ^DIE K DIE
    61         . S V3=0 F  S V3=$O(^SDWL(409.6,"AMSG",BATCH,V1,V2,V3)) Q:'V3  D
    62         .. S ZNODE=$G(^SDWL(409.6,V2,1,V3,0)) Q:ZNODE=""
    63         .. ;4TH PIECE IS MESSAGE NUMBER
    64         .. S DA=V3,DA(1)=V2,DIE="^SDWL(409.6,"_V2_",1,"
    65         .. S DR="7////"_$O(^SCPT(404.472,"B","R","")) D ^DIE
    66         .. I $D(^SDWL(409.6,"AE","Y",V2,V3)) Q
    67         .. I $D(^SDWL(409.6,"AE","N",V2,V3)) D
    68         ... S DR="4///Y" D ^DIE
    69         Q
    70 AA(BATCH,BATCHIDO)      ;whole batch accept
    71         ;if the batch is accepted and no rejections then get the run # sequence #
    72         ;from AMSG xref.  If no "AE","Y" xref then call DIK to delete the entry
    73         ;BATCH    :  originating batch number
    74         ;BATCHIDO :  original batch number from HL7 ACK
    75         ;V1       :  sequence #  (individual message number in batch)
    76         ;V2       :  run #       (ien of multiple entry)
    77         ;V3       :  ien         (ien in patient multiple)
    78         ;V4       :  ien         (ien batch tracking multiple)
    79         Q:($G(BATCH)="")
    80         N DA,DIK,DR,V1,V2,V3,V4,ZNODE
    81         S V1=0
    82         F  S V1=$O(^SDWL(409.6,"AMSG",BATCH,V1)) Q:'V1  D
    83         . S V2=$O(^SDWL(409.6,"AMSG",BATCH,V1,"")) Q:'V2
    84         . ;batch tracking enhancement
    85         . S V4=$O(^SDWL(409.6,V2,2,"B",BATCHIDO,"")) Q:'V4  D
    86         .. S DA=V4,DA(1)=V2,DIE="^SDWL(409.6,"_V2_",2,",DR=".04///"_$$NOW^XLFDT_";.05///"_ACKCODE
    87         .. D ^DIE K DIE
    88         . S V3=0 F  S V3=$O(^SDWL(409.6,"AMSG",BATCH,V1,V2,V3)) Q:'V3  D
    89         .. S ZNODE=$G(^SDWL(409.6,V2,1,V3,0)) Q:ZNODE=""
    90         .. ;4th piece is the message #
    91         .. I '$D(^SDWL(409.6,"AE","Y",V2,V3)) D
    92         ... S DIK="^SDWL(409.6,"_V2_",1,"
    93         ... S DA(1)=V2,DA=V3 D ^DIK
    94         ... S ^XTMP("SDRPA-"_BATCH,+$P(ZNODE,"^",4),0)=ZNODE ;diagnostics
    95         Q
    96 AAAR(BATCH,BATCHIDO)    ;batch accept with errors
    97         ;BATCH    :  originating batch number
    98         ;BATCHIDO :  original batch number from HL7 ACK
    99         ;V1       :  sequence #  (individual message number in batch)
    100         ;V2       :  run #       (ien of multiple entry)
    101         ;V3       :  ien         (ien in patient multiple)
    102         ;V4       :  ien         (ien batch tracking multiple))
    103         Q:($G(BATCH)="")
    104         N DA,DIK,DR,V1,V2,V3,V4,ZNODE
    105         S V1=0
    106         F  S V1=$O(^SDWL(409.6,"AMSG",BATCH,V1)) Q:'V1  D
    107         . S V2=$O(^SDWL(409.6,"AMSG",BATCH,V1,"")) Q:'V2
    108         . ;batch tracking enhancement
    109         . S V4=$O(^SDWL(409.6,V2,2,"B",BATCHIDO,"")) Q:'V4  D
    110         .. S DA=V4,DA(1)=V2,DIE="^SDWL(409.6,"_V2_",2,",DR=".04///"_$$NOW^XLFDT_";.05///"_ACKCODE
    111         .. D ^DIE K DIE
    112         . S V3=0 F  S V3=$O(^SDWL(409.6,"AMSG",BATCH,V1,V2,V3)) Q:'V3  D
    113         .. S ZNODE=$G(^SDWL(409.6,V2,1,V3,0)) Q:ZNODE=""
    114         .. ;4th piece is the message #
    115         .. ;next line screens for accepted batch + accepted message + status final and can be deleted
    116         .. I '$D(^SDWL(409.6,"AE","Y",V2,V3))&('$D(^TMP("SDRPA06",$J,$P(ZNODE,"^",4)))) D
    117         ... S DIK="^SDWL(409.6,"_V2_",1,"
    118         ... S DA(1)=V2,DA=V3 D ^DIK
    119         ... S ^XTMP("SDRPA-"_BATCH,+$P(ZNODE,"^",4),0)=ZNODE ;diagnostics
    120         .. ;next line screens for accepted batch + error message
    121         .. I $D(^TMP("SDRPA06",$J,$P(ZNODE,"^",4))) D
    122         ... S DA=V3,DA(1)=V2,DIE="^SDWL(409.6,"_V2_",1,"
    123         ... S DR="7////"_$O(^SCPT(404.472,"B",$G(^TMP("SDRPA06",$J,$P(ZNODE,"^",4))),"")) D ^DIE
    124         ... I $D(^SDWL(409.6,"AE","Y",V2,V3)) Q
    125         ... I $D(^SDWL(409.6,"AE","N",V2,V3)) D
    126         .... S DR="4///Y" D ^DIE
    127         Q
    128 CLEAN(RUN)      ;housekeeping
    129         ;clean up batch previous to current one by checking for "AE",("S" or "R") xref and
    130         ;deleting if entry in xref exists
    131         ;RUN  :  run #           (ien of multiple entry)
    132         ;V1   :  previous run #  (ien of multiple entry) 
    133         ;V2   :  ien           (ien in multiple)
    134         Q:($G(RUN)="")
    135         N V1,V2,V3
    136         S V1=$O(^SDWL(409.6,RUN),-1) Q:'V1
    137         F V3="R","S" S V2=0 F  S V2=$O(^SDWL(409.6,"AE",V3,V1,V2)) Q:'V2  D
    138         . S ZNODE=$G(^SDWL(409.6,V1,1,V2,0))
    139         . S DIK="^SDWL(409.6,"_V1_",1,"
    140         . S DA(1)=V1,DA=V2 D ^DIK
    141         . S ^XTMP("SDRPA-"_$P(ZNODE,"^",3),"CLEAN",+$P(ZNODE,"^",4),0)=ZNODE ;diagnostics
    142         Q
    143 MSG(BATCHIDO,TYPE,RUNIEN,BATCHID)       ;acknowledgement notification to mail group
    144         ;BATCHID :  Our Message ID
    145         ;BATCHIDO:  Batch Control ID
    146         ;TYPE    :  type of message (accept with rejects - 1, whole accept 2, whole reject -3)
    147         ;RUNIEN  :  run ien associated with this batch
    148         ;SDAMX   :  message text array
    149         ;XMSUB   :  subject
    150         ;XMY     :  addressee
    151         ;XMTEXT  :  location of text array
    152         ;XMDUZ   :  sender of the message
    153         ;RUNZ    :  zero node of run associated with this batch
    154         N RUNZ,SDAMX,V0,V1,V2,V3,XMSUB,XMY,XMTEXT,XMDUZ
    155         Q:BATCHID=""
    156         L +^SDWL(409.6,RUNIEN,2,0)
    157         S V0=$P($G(^SDWL(409.6,RUNIEN,2,0)),"^",4)
    158         S (V1,V3)=0 F  S V1=$O(^SDWL(409.6,RUNIEN,2,V1)) Q:'V1  D
    159         . S:$P($G(^SDWL(409.6,RUNIEN,2,V1,0)),"^",4)'="" V3=V3+1
    160         L -^SDWL(409.6,RUNIEN,2,0)
    161         S RUNZ=$G(^SDWL(409.6,RUNIEN,0))
    162         S XMSUB="PAIT BATCH ACKNOWLEGEMENT "_BATCHIDO
    163         S XMY("G.SD-PAIT")=""
    164         S XMY("S.SD-PAIT-SERVER@FORUM.VA.GOV")=""
    165         S XMTEXT="SDAMX("
    166         S XMDUZ="POSTMASTER"
    167         I TYPE=1 D
    168         . S SDAMX(1)="  Station Number: "_$P($$SITE^VASITE(),"^",3)
    169         . S SDAMX(2)="Batch Control ID: "_BATCHIDO
    170         . S SDAMX(3)="      Message ID: "_BATCHID
    171         . S SDAMX(4)="       Log Entry: "_RUNIEN
    172         . S SDAMX(5)="        Run Date: "_$$FMTE^XLFDT($P(RUNZ,"^",7))
    173         . S SDAMX(6)="          Status: Acknowledged - with rejections "
    174         . S SDAMX(7)="                  "_V3_" of "_V0_" ACKs received for this run date"
    175         . S SDAMX(8)=""
    176         . S SDAMX(9)="Use option SD-PAIT REJECTED  Rejected Transmissions to view the rejections."
    177         I TYPE=2 D
    178         . S SDAMX(1)="  Station Number: "_$P($$SITE^VASITE(),"^",3)
    179         . S SDAMX(2)="Batch Control ID: "_BATCHIDO
    180         . S SDAMX(3)="      Message ID: "_BATCHID
    181         . S SDAMX(4)="       Log Entry: "_RUNIEN
    182         . S SDAMX(5)="        Run Date: "_$$FMTE^XLFDT($P(RUNZ,"^",7))
    183         . S SDAMX(6)="          Status: Acknowledged - No Rejections"
    184         . S SDAMX(7)="                  "_V3_" of "_V0_" ACKs received for this run date"
    185         I TYPE=3 D
    186         . S SDAMX(1)="  Station Number: "_$P($$SITE^VASITE(),"^",3)
    187         . S SDAMX(2)="Batch Control ID: "_BATCHIDO
    188         . S SDAMX(3)="      Message ID: "_BATCHID
    189         . S SDAMX(4)="       Log Entry: "_RUNIEN
    190         . S SDAMX(5)="        Run Date: "_$$FMTE^XLFDT($P(RUNZ,"^",7))
    191         . S SDAMX(6)="          Status: Acknowledged - Entire Batch Rejected"
    192         . S SDAMX(7)="                  "_V3_" of "_V0_" ACKs received for this run date"
    193         D ^XMD
    194         Q
    195 OURB(RUNIEN,BATCHIDO)   ;match batch id to msg control id ("AMSG" xref)
    196         ;RUNIEN     :  the ien in file 409.6 of the run
    197         ;BATCHIDO   :  batchid pulled from the ACK message
    198         ;V2         :  returns 0 if none, or msg control id
    199         N V1,V2,VNODE
    200         S V2=0
    201         I '$G(RUNIEN) Q V2
    202         I '$G(BATCHIDO) Q V2
    203         I $G(^SDWL(409.6,RUNIEN,2,0))="" Q V2
    204         S V1=0 F  S V1=$O(^SDWL(409.6,RUNIEN,2,"B",BATCHIDO,V1)) Q:'V1  D
    205         . S VNODE=$G(^SDWL(409.6,RUNIEN,2,V1,0)) Q:VNODE=""
    206         . I $P(VNODE,"^",3)="" Q
    207         . S V2=$P(VNODE,"^",3) Q
    208         Q V2
    209 RUNIEN(BATCHID) ;get runien
    210         N V1,V2
    211         S V2=0
    212         S V1=999999999 F  S V1=$O(^SDWL(409.6,V1),-1) Q:'V1!(V2)  D
    213         . I $O(^SDWL(409.6,V1,2,"B",BATCHID,"")) S V2=V1 Q
    214         Q V2
     1SDRPA06 ;bp-oifo/swo pait hl7 ack handling ; 10/31/04 3:53pm
     2 ;;5.3;Scheduling;**290,333,349,376**;AUG 13, 1993
     3 ;routine called from Vista HL7 when ack messages are received in response
     4 ;to an out going HL7 message generated by protocol SC-PAIT-EVENT
     5ACK ;entry point from Vista HL7
     6 ;ACKDATE   :  date/time ack received
     7 ;FLDSEP    :  field separator
     8 ;CMPNTSEP  :  component separator
     9 ;REPTNSEP  :  repetition separator
     10 ;ACKCODE   :  acknowledgement code
     11 ;ERROR     :  reject reason
     12 ;BATCHID   :  batch control ID
     13 ;BATCHIDO  :  original batch control ID
     14 N ACKCODE,ACKDATE,BATCHID,BATCHIDO,CMPNTSEP,ERROR,FLDSEP,REPTNSEP,RUNIEN,SDZAP,V1
     15 ;disable automatic repair of the last run, not needed to process acks
     16 ;NHD will be notified when the completion message does not come out
     17 ;D RSTAT^SDRPA02 ;check the status of the last run
     18 K ^TMP("SDRPA06",$J)
     19 S SDZAP=0
     20 S ACKDATE=$$NOW^XLFDT()
     21 S FLDSEP=HL("FS")
     22 S CMPNTSEP=$E(HL("ECH"),1)
     23 S REPTNSEP=$E(HL("ECH"),2)
     24 S ACKCODE=$P(HLMSA,FLDSEP)
     25 S ERROR=$P(HLMSA,FLDSEP,4)
     26 S (BATCHID,BATCHIDO)=$P(HLMSA,FLDSEP,2)
     27 S RUNIEN=$$RUNIEN(BATCHIDO) Q:'RUNIEN
     28 S BATCHID=$$OURB(RUNIEN,BATCHIDO) ;convert to our batch id
     29 Q:'BATCHID  ;error needs to be handled
     30 ;S V1=$O(^SDWL(409.6,"AMSG",BATCHID,"")),RUNIEN=$O(^SDWL(409.6,"AMSG",BATCHID,V1,""))
     31 S V1=$O(^SDWL(409.6,"AMSG",BATCHID,"")) Q:V1=""
     32 Q:'$$DUP^SDRPA02(RUNIEN,BATCHIDO)  ;check for duplicate
     33 S ^XTMP("SDRPA-"_BATCHID,0)=$$FMADD^XLFDT($$DT^XLFDT(),3)_"^"_$$DT^XLFDT() ;set xtmp global for diagnostics
     34 I $E(ACKCODE,1,2)="AR" D AR(BATCHID,BATCHIDO),MSG(BATCHIDO,3,RUNIEN,BATCHID) Q  ;whole batch rejection
     35 ;Q:($E(ACKCODE,1,2)'="AA")  ;quit if not a application ack
     36 ;will only be 2 ACKCODEs AA and AE so don't have to screen anymore
     37 F  X HLNEXT Q:(HLQUIT'>0)  D  ;start looping the msg text
     38 . Q:($E(HLNODE,1,3)'="MSA")  ;skip if not a MSA segment
     39 . I $P(HLNODE,FLDSEP,2)="AE" D  ;it's an error
     40 .. Q:($P($P(HLNODE,FLDSEP,3),"-",2))=""  ;no message number
     41 .. S ^TMP("SDRPA06",$J,+$P($P(HLNODE,FLDSEP,3),"-",2))=+$P(HLNODE,"^",4) ;set xref with message #
     42 I '$D(^TMP("SDRPA06",$J)) D AA(BATCHID,BATCHIDO),MSG(BATCHIDO,2,RUNIEN,BATCHID) Q  ;whole batch accept
     43 D AAAR(BATCHID,BATCHIDO),MSG(BATCHIDO,1,RUNIEN,BATCHID) ;batch accept with errors   
     44 Q
     45AR(BATCH,BATCHIDO) ;whole batch rejection
     46 ;BATCH    :  originating batch number
     47 ;BATCHIDO :  original batch number from HL7 ACK
     48 ;V1       :  sequence #  (individual message number in batch)
     49 ;V2       :  run #       (ien of multiple entry)
     50 ;V3       :  ien         (ien in patient multiple)
     51 ;V4       :  ien         (ien batch tracking multiple)
     52 Q:($G(BATCH)="")
     53 N DA,DIE,DR,V1,V2,V3,V4,ZNODE
     54 S V1=0
     55 F  S V1=$O(^SDWL(409.6,"AMSG",BATCH,V1)) Q:'V1  D
     56 . S V2=$O(^SDWL(409.6,"AMSG",BATCH,V1,"")) Q:'V2
     57 . ;batch tracking enhancement
     58 . S V4=$O(^SDWL(409.6,V2,2,"B",BATCHIDO,"")) Q:'V4  D
     59 .. S DA=V4,DA(1)=V2,DIE="^SDWL(409.6,"_V2_",2,",DR=".04///"_$$NOW^XLFDT_";.05///"_ACKCODE
     60 .. D ^DIE K DIE
     61 . S V3=0 F  S V3=$O(^SDWL(409.6,"AMSG",BATCH,V1,V2,V3)) Q:'V3  D
     62 .. S ZNODE=$G(^SDWL(409.6,V2,1,V3,0)) Q:ZNODE=""
     63 .. ;4TH PIECE IS MESSAGE NUMBER
     64 .. S DA=V3,DA(1)=V2,DIE="^SDWL(409.6,"_V2_",1,"
     65 .. S DR="7////"_$O(^SCPT(404.472,"B","R","")) D ^DIE
     66 .. I $D(^SDWL(409.6,"AE","Y",V2,V3)) Q
     67 .. I $D(^SDWL(409.6,"AE","N",V2,V3)) D
     68 ... S DR="4///Y" D ^DIE
     69 Q
     70AA(BATCH,BATCHIDO) ;whole batch accept
     71 ;if the batch is accepted and no rejections then get the run # sequence #
     72 ;from AMSG xref.  If no "AE","Y" xref then call DIK to delete the entry
     73 ;BATCH    :  originating batch number
     74 ;BATCHIDO :  original batch number from HL7 ACK
     75 ;V1       :  sequence #  (individual message number in batch)
     76 ;V2       :  run #       (ien of multiple entry)
     77 ;V3       :  ien         (ien in patient multiple)
     78 ;V4       :  ien         (ien batch tracking multiple)
     79 Q:($G(BATCH)="")
     80 N DA,DIK,DR,V1,V2,V3,V4,ZNODE
     81 S V1=0
     82 F  S V1=$O(^SDWL(409.6,"AMSG",BATCH,V1)) Q:'V1  D
     83 . S V2=$O(^SDWL(409.6,"AMSG",BATCH,V1,"")) Q:'V2
     84 . ;batch tracking enhancement
     85 . S V4=$O(^SDWL(409.6,V2,2,"B",BATCHIDO,"")) Q:'V4  D
     86 .. S DA=V4,DA(1)=V2,DIE="^SDWL(409.6,"_V2_",2,",DR=".04///"_$$NOW^XLFDT_";.05///"_ACKCODE
     87 .. D ^DIE K DIE
     88 . S V3=0 F  S V3=$O(^SDWL(409.6,"AMSG",BATCH,V1,V2,V3)) Q:'V3  D
     89 .. S ZNODE=$G(^SDWL(409.6,V2,1,V3,0)) Q:ZNODE=""
     90 .. ;4th piece is the message #
     91 .. I '$D(^SDWL(409.6,"AE","Y",V2,V3)) D
     92 ... S DIK="^SDWL(409.6,"_V2_",1,"
     93 ... S DA(1)=V2,DA=V3 D ^DIK
     94 ... S ^XTMP("SDRPA-"_BATCH,+$P(ZNODE,"^",4),0)=ZNODE ;diagnostics
     95 Q
     96AAAR(BATCH,BATCHIDO) ;batch accept with errors
     97 ;BATCH    :  originating batch number
     98 ;BATCHIDO :  original batch number from HL7 ACK
     99 ;V1       :  sequence #  (individual message number in batch)
     100 ;V2       :  run #       (ien of multiple entry)
     101 ;V3       :  ien         (ien in patient multiple)
     102 ;V4       :  ien         (ien batch tracking multiple))
     103 Q:($G(BATCH)="")
     104 N DA,DIK,DR,V1,V2,V3,V4,ZNODE
     105 S V1=0
     106 F  S V1=$O(^SDWL(409.6,"AMSG",BATCH,V1)) Q:'V1  D
     107 . S V2=$O(^SDWL(409.6,"AMSG",BATCH,V1,"")) Q:'V2
     108 . ;batch tracking enhancement
     109 . S V4=$O(^SDWL(409.6,V2,2,"B",BATCHIDO,"")) Q:'V4  D
     110 .. S DA=V4,DA(1)=V2,DIE="^SDWL(409.6,"_V2_",2,",DR=".04///"_$$NOW^XLFDT_";.05///"_ACKCODE
     111 .. D ^DIE K DIE
     112 . S V3=0 F  S V3=$O(^SDWL(409.6,"AMSG",BATCH,V1,V2,V3)) Q:'V3  D
     113 .. S ZNODE=$G(^SDWL(409.6,V2,1,V3,0)) Q:ZNODE=""
     114 .. ;4th piece is the message #
     115 .. ;next line screens for accepted batch + accepted message + status final and can be deleted
     116 .. I '$D(^SDWL(409.6,"AE","Y",V2,V3))&('$D(^TMP("SDRPA06",$J,$P(ZNODE,"^",4)))) D
     117 ... S DIK="^SDWL(409.6,"_V2_",1,"
     118 ... S DA(1)=V2,DA=V3 D ^DIK
     119 ... S ^XTMP("SDRPA-"_BATCH,+$P(ZNODE,"^",4),0)=ZNODE ;diagnostics
     120 .. ;next line screens for accepted batch + error message
     121 .. I $D(^TMP("SDRPA06",$J,$P(ZNODE,"^",4))) D
     122 ... S DA=V3,DA(1)=V2,DIE="^SDWL(409.6,"_V2_",1,"
     123 ... S DR="7////"_$O(^SCPT(404.472,"B",$G(^TMP("SDRPA06",$J,$P(ZNODE,"^",4))),"")) D ^DIE
     124 ... I $D(^SDWL(409.6,"AE","Y",V2,V3)) Q
     125 ... I $D(^SDWL(409.6,"AE","N",V2,V3)) D
     126 .... S DR="4///Y" D ^DIE
     127 Q
     128CLEAN(RUN) ;housekeeping
     129 ;clean up batch previous to current one by checking for "AE",("S" or "R") xref and
     130 ;deleting if entry in xref exists
     131 ;RUN  :  run #           (ien of multiple entry)
     132 ;V1   :  previous run #  (ien of multiple entry) 
     133 ;V2   :  ien           (ien in multiple)
     134 Q:($G(RUN)="")
     135 N V1,V2,V3
     136 S V1=$O(^SDWL(409.6,RUN),-1) Q:'V1
     137 F V3="R","S" S V2=0 F  S V2=$O(^SDWL(409.6,"AE",V3,V1,V2)) Q:'V2  D
     138 . S ZNODE=$G(^SDWL(409.6,V1,1,V2,0))
     139 . S DIK="^SDWL(409.6,"_V1_",1,"
     140 . S DA(1)=V1,DA=V2 D ^DIK
     141 . S ^XTMP("SDRPA-"_$P(ZNODE,"^",3),"CLEAN",+$P(ZNODE,"^",4),0)=ZNODE ;diagnostics
     142 Q
     143MSG(BATCHIDO,TYPE,RUNIEN,BATCHID) ;acknowledgement notification to mail group
     144 ;BATCHID :  Our Message ID
     145 ;BATCHIDO:  Batch Control ID
     146 ;TYPE    :  type of message (accept with rejects - 1, whole accept 2, whole reject -3)
     147 ;RUNIEN  :  run ien associated with this batch
     148 ;SDAMX   :  message text array
     149 ;XMSUB   :  subject
     150 ;XMY     :  addressee
     151 ;XMTEXT  :  location of text array
     152 ;XMDUZ   :  sender of the message
     153 ;RUNZ    :  zero node of run associated with this batch
     154 N RUNZ,SDAMX,V0,V1,V2,V3,XMSUB,XMY,XMTEXT,XMDUZ
     155 Q:BATCHID=""
     156 S V0=$P($G(^SDWL(409.6,RUNIEN,2,0)),"^",4)
     157 S (V1,V3)=0 F  S V1=$O(^SDWL(409.6,RUNIEN,2,V1)) Q:'V1  D
     158 . S V2=$P($G(^SDWL(409.6,RUNIEN,2,V1,0)),"^",4)
     159 . S:V2'="" V3=V3+1
     160 . ;S V3=V3+1
     161 S RUNZ=$G(^SDWL(409.6,RUNIEN,0))
     162 S XMSUB="PAIT BATCH ACKNOWLEGEMENT "_BATCHIDO
     163 S XMY("G.SD-PAIT")=""
     164 S XMY("S.SD-PAIT-SERVER@FORUM.VA.GOV")=""
     165 S XMTEXT="SDAMX("
     166 S XMDUZ="POSTMASTER"
     167 I TYPE=1 D
     168 . S SDAMX(1)="  Station Number: "_$P($$SITE^VASITE(),"^",3)
     169 . S SDAMX(2)="Batch Control ID: "_BATCHIDO
     170 . S SDAMX(3)="      Message ID: "_BATCHID
     171 . S SDAMX(4)="       Log Entry: "_RUNIEN
     172 . S SDAMX(5)="        Run Date: "_$$FMTE^XLFDT($P(RUNZ,"^",7))
     173 . S SDAMX(6)="          Status: Acknowledged - with rejections "
     174 . S SDAMX(7)="                  "_V3_" of "_V0_" ACKs received for this run date"
     175 . S SDAMX(8)=""
     176 . S SDAMX(9)="Use option SD-PAIT REJECTED  Rejected Transmissions to view the rejections."
     177 I TYPE=2 D
     178 . S SDAMX(1)="  Station Number: "_$P($$SITE^VASITE(),"^",3)
     179 . S SDAMX(2)="Batch Control ID: "_BATCHIDO
     180 . S SDAMX(3)="      Message ID: "_BATCHID
     181 . S SDAMX(4)="       Log Entry: "_RUNIEN
     182 . S SDAMX(5)="        Run Date: "_$$FMTE^XLFDT($P(RUNZ,"^",7))
     183 . S SDAMX(6)="          Status: Acknowledged - No Rejections"
     184 . S SDAMX(7)="                  "_V3_" of "_V0_" ACKs received for this run date"
     185 I TYPE=3 D
     186 . S SDAMX(1)="  Station Number: "_$P($$SITE^VASITE(),"^",3)
     187 . S SDAMX(2)="Batch Control ID: "_BATCHIDO
     188 . S SDAMX(3)="      Message ID: "_BATCHID
     189 . S SDAMX(4)="       Log Entry: "_RUNIEN
     190 . S SDAMX(5)="        Run Date: "_$$FMTE^XLFDT($P(RUNZ,"^",7))
     191 . S SDAMX(6)="          Status: Acknowledged - Entire Batch Rejected"
     192 . S SDAMX(7)="                  "_V3_" of "_V0_" ACKs received for this run date"
     193 D ^XMD
     194 Q
     195OURB(RUNIEN,BATCHIDO) ;match batch id to msg control id ("AMSG" xref)
     196 ;RUNIEN     :  the ien in file 409.6 of the run
     197 ;BATCHIDO   :  batchid pulled from the ACK message
     198 ;V2         :  returns 0 if none, or msg control id
     199 N V1,V2,VNODE
     200 S V2=0
     201 I '$G(RUNIEN) Q V2
     202 I '$G(BATCHIDO) Q V2
     203 I $G(^SDWL(409.6,RUNIEN,2,0))="" Q V2
     204 S V1=0 F  S V1=$O(^SDWL(409.6,RUNIEN,2,"B",BATCHIDO,V1)) Q:'V1  D
     205 . S VNODE=$G(^SDWL(409.6,RUNIEN,2,V1,0)) Q:VNODE=""
     206 . I $P(VNODE,"^",3)="" Q
     207 . S V2=$P(VNODE,"^",3) Q
     208 Q V2
     209RUNIEN(BATCHID) ;get runien
     210 N V1,V2
     211 S V2=0
     212 S V1=999999999 F  S V1=$O(^SDWL(409.6,V1),-1) Q:'V1!(V2)  D
     213 . I $O(^SDWL(409.6,V1,2,"B",BATCHID,"")) S V2=V1 Q
     214 Q V2

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDWLCU3.m

    r613 r623  
    1 SDWLCU3 ;IOFO BAY PINES/DMR - EWL FILE 409.3 CLEANUP ;2/4/03
    2         ;;5.3;scheduling;**280,491**;AUG 13 1993;Build 53
    3         ;
    4         ;modify update of 409.32 and related 409.3 with a proper institution set up in file 44
    5         ;through the division path
    6         ;
    7 3       ;service specialty edit
    8         S SDWLSS="",SDWLINS="",SDWLERR=""
    9         F  S SDWLINS=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS)) Q:SDWLINS=""  D  Q:SDWLERR=1
    10         .F  S SDWLSS=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSS)) Q:SDWLSS=""  D  Q:SDWLERR=1
    11         ..I '$D(SDWLSSV) S SDWLSSV=SDWLSS
    12         ..S NAME=$$GET1^DIQ(4,SDWLINS_",",.01)
    13         ..S SDWLSSN=$P(^SDWL(409.31,SDWLSS,0),U,1)
    14         ..W !,"SERVICE SPECIALTY: ",$$GET1^DIQ(40.7,SDWLSSN_",",.01),"   INSTITUTION: ",NAME
    15         ..S SDWLSSX=$O(^SDWL(409.31,SDWLSS,"I","B",SDWLINS,0)) D:SDWLSSX'="" SEL
    16         S WLTC3=""
    17         Q
    18 SEL     ;select new Insitition
    19         N DIR
    20         S DIR("A")="Select Institution: "
    21         S DIR(0)="PAO^4:EMZ",DIR("S")="I $P(^DIC(4,+Y,0),U,11)=""N"",$$TF^XUAF4(+Y)" D ^DIR
    22         I X["^" S SDWLERR=1 Q
    23         I Y<1 W *7,"Invalid Entry" G SEL
    24         S SDWLINSN=+Y
    25         D C3,C31 K DIC,D0,D1
    26         Q
    27 C3      ;
    28         ;check entry to see if it already exist
    29         S DA=SDWLSSX,DA(1)=SDWLSS
    30         I $O(^SDWL(409.31,SDWLSS,"I","B",SDWLINSN,0)) D
    31         . W !,"Institution already exists for this Specialty...deleting."
    32         . S DIK="^SDWL(409.31,"_DA(1)_","_"""I"""_"," D ^DIK
    33         E  D
    34         . W ! S DR=".01////^S X=SDWLINSN",DIE="^SDWL(409.31,"_DA(1)_","_"""I"""_"," D ^DIE
    35         K DA,DA(1),DR,DIE,DIK
    36         Q
    37 C31     ;update SD WAIT LIST PATIENT file 409.3
    38         S SDWLDA="" F  S SDWLDA=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSSV,SDWLDA)) Q:SDWLDA=""  D
    39         .S DR="2////^S X=SDWLINSN",DIE="^SDWL(409.3,",DA=SDWLDA D ^DIE
    40         .K DR,DIE,DA
    41         .K ^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSSV,SDWLDA),^TMP($J,"EWL",$J,SDWLDA)
    42         Q
    43 4       ;specific clinic edit
    44         N SDWLERR,SDWLSC,SDWLINS S SDWLSC="",SDWLINS="",SDWLERR=""
    45         F  S SDWLINS=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS)) Q:SDWLINS=""  D
    46         .F  S SDWLSC=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSC)) Q:SDWLSC=""  D UPDINS^SDWLCU5(SDWLSC,.SDWLERR)
    47         Q:SDWLERR
    48         S WLTC4=""
    49         K ^SDWL(409.32,"ACT") S DIK="^SDWL(409.32," D IXALL^DIK
    50         Q
    51 C41     ;update wait list file
    52         S SDWLDA="" F  S SDWLDA=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSC,SDWLDA)) Q:SDWLDA=""  D
    53         .S SDWLIN(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLIN","SDWLMSG")
    54         .K ^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSC,SDWLDA),^TMP($J,"EWL",$J,SDWLDA),SDWLIN
    55         Q
    56 SEL1    ;select valid institution
    57         N DIR
    58         W !!,"Invalid Institution. Please select a National Institution.",!
    59         W "CLINIC: ",CLNAM,"   INSTITUTION:",$$GET1^DIQ(4,SDWLINS_",",.01)
    60         S DIR("A")="Select Institution: "
    61         S DIR(0)="PAO^4:EMZ",DIR("S")="I $P(^DIC(4,+Y,0),U,11)=""N"",$$TF^XUAF4(+Y)" D ^DIR
    62         I X["^" S SDWLERR=1 Q
    63         I Y<1 W *7,"Invalid Entry" G SEL1
    64         S SDWLINSN=+Y
    65         Q
     1SDWLCU3 ;IOFO BAY PINES/DMR - EWL FILE 409.3 CLEANUP ;2/4/03
     2 ;;5.3;scheduling;**280**;AUG 13 1993
     3 ;
     4 ;
     5 ;
     63 ;service specialty edit
     7 S SDWLSS="",SDWLINS="",SDWLERR=""
     8 F  S SDWLINS=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS)) Q:SDWLINS=""  D  Q:SDWLERR=1
     9 .F  S SDWLSS=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSS)) Q:SDWLSS=""  D  Q:SDWLERR=1
     10 ..I '$D(SDWLSSV) S SDWLSSV=SDWLSS
     11 ..S NAME=$$GET1^DIQ(4,SDWLINS_",",.01)
     12 ..S SDWLSSN=$P(^SDWL(409.31,SDWLSS,0),U,1)
     13 ..W !,"SERVICE SPECIALTY: ",$$GET1^DIQ(40.7,SDWLSSN_",",.01),"   INSTITUTION: ",NAME
     14 ..S SDWLSSX=$O(^SDWL(409.31,SDWLSS,"I","B",SDWLINS,0)) D:SDWLSSX'="" SEL
     15 S WLTC3=""
     16 Q
     17SEL ;select new Insitition
     18 N DIR
     19 S DIR("A")="Select Institution: "
     20 S DIR(0)="PAO^4:EMZ",DIR("S")="I $P(^DIC(4,+Y,0),U,11)=""N"",$$TF^XUAF4(+Y)" D ^DIR
     21 I X["^" S SDWLERR=1 Q
     22 I Y<1 W *7,"Invalid Entry" G SEL
     23 S SDWLINSN=+Y
     24 D C3,C31 K DIC,D0,D1
     25 Q
     26C3 ;
     27 ;check entry to see if it already exist
     28 S DA=SDWLSSX,DA(1)=SDWLSS
     29 I $O(^SDWL(409.31,SDWLSS,"I","B",SDWLINSN,0)) D
     30 . W !,"Institution already exists for this Specialty...deleting."
     31 . S DIK="^SDWL(409.31,"_DA(1)_","_"""I"""_"," D ^DIK
     32 E  D
     33 . W ! S DR=".01////^S X=SDWLINSN",DIE="^SDWL(409.31,"_DA(1)_","_"""I"""_"," D ^DIE
     34 K DA,DA(1),DR,DIE,DIK
     35 Q
     36C31 ;update SD WAIT LIST PATIENT file 409.3
     37 S SDWLDA="" F  S SDWLDA=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSSV,SDWLDA)) Q:SDWLDA=""  D
     38 .S DR="2////^S X=SDWLINSN",DIE="^SDWL(409.3,",DA=SDWLDA D ^DIE
     39 .K DR,DIE,DA
     40 .K ^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSSV,SDWLDA),^TMP($J,"EWL",$J,SDWLDA)
     41 Q
     424 ;specific clinic edit
     43 S SDWLSC="",SDWLINS="",SDWLERR=""
     44 F  S SDWLINS=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS)) Q:SDWLINS=""  D  Q:SDWLERR=1
     45 .F  S SDWLSC=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSC)) Q:SDWLSC=""  D  Q:SDWLERR=1
     46 ..S SDWLSCX=$P(^SDWL(409.32,SDWLSC,0),U,1)
     47 ..S SDWLINSN=$P($G(^SC(SDWLSCX,0)),U,4),X=$$GET1^DIQ(4,SDWLINSN_",",11) I X'["N"!('$$TF^XUAF4(SDWLINSN)) D SEL1
     48 ..;Check 409.32
     49 ..I $P(^SDWL(409.32,SDWLSC,0),U,6)'=SDWLINSN  D
     50 ...K ^SDWL(409.32,"C",SDWLINS) S $P(^SDWL(409.32,SDWLSC,0),U,6)=SDWLINSN,^SDWL(409.32,"C",SDWLINSN,SDWLSC)=""
     51 ...S SDWLIN(44,+$P(^SDWL(409.32,SDWLSC,0),"^")_",",3)=SDWLINSN D UPDATE^DIE("","SDWLIN","SDWLMSG") K SDWLIN
     52 ..D C41
     53 S WLTC4=""
     54 K ^SDWL(409.32,"ACT") S DIK="^SDWL(409.32," D IXALL^DIK
     55 Q
     56C41 ;update wait list file
     57 S SDWLDA="" F  S SDWLDA=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSC,SDWLDA)) Q:SDWLDA=""  D
     58 .S SDWLIN(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLIN","SDWLMSG")
     59 .K ^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSC,SDWLDA),^TMP($J,"EWL",$J,SDWLDA),SDWLIN
     60 Q
     61SEL1 ;select valid institution
     62 N DIR
     63 W !!,"Invalid Institution. Please select a National Institution.",!
     64 W "CLINIC: ",CLNAM,"   INSTITUTION:",$$GET1^DIQ(4,SDWLINS_",",.01)
     65 S DIR("A")="Select Institution: "
     66 S DIR(0)="PAO^4:EMZ",DIR("S")="I $P(^DIC(4,+Y,0),U,11)=""N"",$$TF^XUAF4(+Y)" D ^DIR
     67 I X["^" S SDWLERR=1 Q
     68 I Y<1 W *7,"Invalid Entry" G SEL1
     69 S SDWLINSN=+Y
     70 Q

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDWLCU5.m

    r613 r623  
    1 SDWLCU5 ;IOFO BAY PINES/TEH - EWL FILE 409.3 CLEANUP ;2/4/03  ; Compiled August 20, 2007 17:04:58
    2         ;;5.3;scheduling;**280,427,491**;AUG 13 1993;Build 53
    3 EN      ;
    4         W !!,"Checking file 404.51 one last time.",!
    5         S SDWLERR="",TEAM=0 F  S TEAM=$O(^SCTM(404.51,TEAM)) Q:'TEAM  D  Q:SDWLERR=1
    6         . S INST=$$GET1^DIQ(404.51,TEAM_",",.07,"I")
    7         . S CODE=$$GET1^DIQ(4,INST_",",11,"I")
    8         . S INCK=$$TF^XUAF4(INST)
    9         . I CODE'="N"!('INCK) D
    10         .. W !!,"TEAM: ",$$GET1^DIQ(404.51,TEAM_",",.01),"    INSTITUTION: "
    11         .. W $$GET1^DIQ(4,INST_",",.01)
    12         .. D EDIT^SDWLCU2
    13         Q:SDWLERR=1
    14         ;
    15         W !!,"Checking file 409.31 one last time.",!
    16 40931   S SDWLSS=0 F  S SDWLSS=$O(^SDWL(409.31,SDWLSS)) Q:'SDWLSS  D  Q:SDWLERR=1
    17         . S SDWLINS="" F  S SDWLINS=$O(^SDWL(409.31,SDWLSS,"I","B",SDWLINS)) Q:'SDWLINS  D  Q:SDWLERR=1
    18         .. S CODE=$$GET1^DIQ(4,SDWLINS_",",11,"I")
    19         .. S INCK=$$TF^XUAF4(SDWLINS)
    20         .. I CODE'="N"!('INCK) D
    21         ... W !!,"SERVICE SPECIALTY: ",$$GET1^DIQ(409.31,SDWLSS_",",.01),"    INSTITUTION: "
    22         ... W $$GET1^DIQ(4,SDWLINS_",",.01)
    23         ... D GETINS Q:SDWLERR=1
    24         ... S SDWLSSX="" F  S SDWLSSX=$O(^SDWL(409.31,SDWLSS,"I","B",SDWLINS,SDWLSSX)) Q:'SDWLSSX  D  Q:SDWLERR=1
    25         .... D C3^SDWLCU3
    26         Q:SDWLERR=1
    27 40932   W !!,"Checking file 409.32 one last time.",!
    28         N INERROR S INERROR="" S SDWLSC=0 F  S SDWLSC=$O(^SDWL(409.32,SDWLSC)) Q:'SDWLSC  D UPDINS(SDWLSC,.INERROR)
    29         Q:INERROR=1
    30         N DIK S DIK="^SDWL(409.32," D IXALL^DIK
    31         W !!,"Checking file 409.3 one last time.",!
    32         S SDWLERR=""
    33         S SDWLDA=0,TAG="CHK" F  S SDWLDA=$O(^SDWL(409.3,SDWLDA)) Q:SDWLDA<1  D  Q:SDWLERR=1
    34         .S X=$G(^SDWL(409.3,SDWLDA,0)),SDWLINST=$P(X,"^",3),SDWLTY=$P(X,"^",5)
    35         .Q:'SDWLTY!'SDWLINST
    36         .S SDWLI=$P(X,"^",SDWLTY+5) Q:'SDWLI
    37         .S TAG="CHK",TAG=TAG_SDWLTY,C=0 K ^TMP($J,"SDWLCU5",$J) D @TAG
    38         W !,"Done."
    39         Q
    40 UPDINS(SDWLSC,INERROR)  ; update 409.32 and the related entroes in 409.3
    41         N SDWLINS S SDWLINS=$$GET1^DIQ(409.32,SDWLSC_",",.02,"I") ; current set up IN 409.32
    42         ;check set up in file 44
    43         ;get clinic
    44         N CL,CLN S CL=$$GET1^DIQ(409.32,SDWLSC_",",.01,"I"),CLN=$$GET1^DIQ(44,CL_",",.01)
    45         N STR,SDWMES S SDWMES="",STR=$$CLIN^SDWLPE(CL)
    46         S SDWMES=SDWMES_$P(STR,U,6)
    47         I $P(STR,U,5)="L" S SDWMES=SDWMES_" - Local Institution assigned to clinic. "
    48         I SDWMES'="" D  Q
    49         .W !!," ** Incorrect Setting up of Clinic "_CLN_" ("_CL_")"_": **"
    50         .W !!,SDWMES
    51         .W !!,"INSTALLATION WILL CONTINUE WITHOUT UPDATING THIS ENTRY."
    52         .W !!,"AFTER INSTALLATION CORRECT THE CLINIC SETUP AND THEN",!," RUN OPTION SD WAIT LIST CLEANUP."
    53         .S:INERROR="" INERROR=1 Q
    54         I +STR'=SDWLINS W !!,"Clinic "_CLN_" ("_CL_")"_"does not have the same Institution as EWL set up." D
    55         .W !!,"EWL Clinic INSTITUTION: ",$$GET1^DIQ(4,SDWLINS_",",.01)_" - "_$$GET1^DIQ(4,SDWLINS_",",99)
    56         .W !,"Clinic INSTITUTION: ",$P(STR,U,3)_" - "_$P(STR,U,2)
    57         .W !!,"EWL set up will be updated with the Clinic from the Hospital Location file,"
    58         .W !,"and the related open EWL entries will be updated as well."
    59         .N DIE,DR,DA S DR=".02////^S X=+STR",DIE="^SDWL(409.32,",DA=SDWLSC
    60         .L +^SDWL(409.32,DA):0 I '$T W !?5,"Another user is editing this entry. try later." Q
    61         .D ^DIE L -^SDWL(409.32,DA)
    62         .;loop to update EWL entries in FILE 409.3 if any
    63         .N SCL,DA,DR,CNT S SCL="",CNT=0 F  S SCL=$O(^SDWL(409.3,"SC",CL,SCL)) Q:SCL'>0  D
    64         ..I '$D(^SDWL(409.3,SCL,0)) K ^SDWL(409.3,"SC",CL,SCL) Q
    65         ..S DR="2////^S X=+STR",DIE="^SDWL(409.3,",DA=SCL
    66         ..L +^SDWL(409.3,SCL):0 I '$T W !?5,"Another user is editing this entry. try later." Q
    67         ..D ^DIE L -^SDWL(409.3,SCL) S CNT=CNT+1
    68         .I CNT>0 W !,CNT_" EWL entries for clinic "_CLN_" updated."
    69         N DA I $$GET1^DIQ(409.32,SDWLSC_",",3,"I")="" I $$GET1^DIQ(409.32,SDWLSC_",",1,"I")'>0 D
    70         .S DA=SDWLSC L +^SDWL(409.32,SDWLSC):0 I '$T W !?5,"Another user is editing this entry. try later." Q
    71         .S DR="1////^S X=DT;2////^S X=DUZ",DIE="^SDWL(409.32," ;enter activation date and user
    72         .D ^DIE L -^SDWL(409.32,SDWLSC)
    73         .W !,"EWL Clinic entry for "_CLN_" updated with today's activation date."
    74         Q
    75 CHK1    ;CHECK FOR INSTITUTION VALIDILITY
    76         S SDWLERR=0
    77         I SDWLTY=1 S SDWLI=0 F  S SDWLI=$O(^SCTM(404.51,"AINST",SDWLI)) Q:SDWLI=""  I $D(^DIC(4,SDWLI)) S C=C+1,^TMP($J,"SDWLCU5",$J,C,SDWLI)="",^TMP($J,"SDWLCU5",$J,"B",SDWLI)=""
    78         I $D(^TMP($J,"SDWLCU5",$J,"B",SDWLINST)) Q
    79         K ^TMP($J,"SDWLCU5",$J,"B")
    80         I 'C S SDWLINSN=$S($D(DUZ(2)):DUZ(2),1:"") D CH1E Q
    81         I C=1 S SDWLINSN=$O(^TMP($J,"SDWLCU5",$J,C,0)) D CH1E Q
    82         W !,"Please select a valid Institution for this record from the following list for",!
    83         D DIS
    84         S C=0,SDWLI="" F  S C=$O(^TMP($J,"SDWLCU5",$J,C)) Q:C<1  D
    85         .F  S SDWLI=$O(^TMP($J,"SDWLCU5",$J,C,SDWLI)) Q:SDWLI=""  W !,?20,C,". ",$$GET1^DIQ(4,SDWLI_",",.01) S CS=C
    86 CHK10   W ! S DIR(0)="NO^1:"_CS D ^DIR
    87         I Y<1!($D(DUOUT)) W !,"Response Required." S SDWLERR=1 Q
    88         S SDWLINSN=$O(^TMP($J,"SDWLCU5",$J,+Y,0))
    89 CH1E    S SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLINS","SDWLMSG")
    90         S TAG="CHK"
    91         Q
    92 CHK3    ;
    93         S SDWLERR=""
    94         S SDWLI=$P(^SDWL(409.3,SDWLDA,0),U,8)
    95         Q:'SDWLI!'$D(^SDWL(409.31,SDWLI))
    96         I '$D(^SDWL(409.31,SDWLI,"I","B",SDWLINST)) D  Q:SDWLERR=1
    97         .S SDWLIX="",C=0 F  S SDWLIX=$O(^SDWL(409.31,SDWLI,"I","B",SDWLIX)) Q:SDWLIX=""  S C=C+1,^TMP($J,"SDWLCU5",$J,C,SDWLIX)="",^TMP($J,"SDWLCU5",$J,"B",SDWLIX)=""
    98         .I 'C N SITE S SITE=+$$SITE^VASITE(,) S SDWLINSN=$S(SITE>0:SITE,1:""),Y=1 D CHE3 Q
    99         .I C=1 S SDWLINSN=$O(^TMP($J,"SDWLCU5",$J,C,0)),Y=1 D CHE3 Q
    100         .W !,"Please select a valid Institution for this record from the following list for",!
    101         .D DIS
    102         .S C=0,SDWLIZ=0 F  S SDWLIZ=$O(^SDWL(409.31,SDWLI,"I","B",SDWLIZ)) Q:SDWLIZ=""  D
    103         ..Q:$$GET1^DIQ(4,SDWLIZ_",",11,"I")'="N"!('$$TF^XUAF4(SDWLIZ))
    104         ..S C=C+1 W !,?20,C,". ",$$GET1^DIQ(4,SDWLIZ_",",.01)
    105         .W ! S DIR(0)="NO^1:"_C D ^DIR
    106         .I $D(DUOUT)!(Y="") S SDWLERR=1 Q
    107         .S SDWLINSN=$O(^TMP($J,"SDWLCU5",$J,+Y,0))
    108         .D CHE3
    109         Q
    110 CHE3    ;
    111         G CHK3:Y<0
    112         S SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLINS","SDWLMSG")
    113         S TAG="CHK"
    114         Q
    115 CHK4    ;
    116         S SDWLI=$P(^SDWL(409.3,SDWLDA,0),U,9)
    117         Q:'SDWLI!'$D(^SDWL(409.32,SDWLI,0))
    118         I $P(^SDWL(409.32,SDWLI,0),U,6)'=SDWLINST D
    119         .D DIS
    120         .S SDWLINSN=$P(^SDWL(409.32,SDWLI,0),U,6),SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLINS","SDWLMSG")
    121         Q
    122 CHK2    ;
    123         S SDWLPO=$P($G(^SDWL(409.3,SDWLDA,0)),U,7),SDWLTM=$P($G(^SCTM(404.57,SDWLPO,0)),U,2),SDWLINSN=$P($G(^SCTM(404.51,SDWLTM,0)),U,7)
    124         I SDWLINST'=SDWLINSN D
    125         .S SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLINS","SDWLMSG")
    126         S TAG="CHK"
    127         Q
    128 DIS     ;display record
    129         S NN=$P($G(^SDWL(409.3,SDWLDA,0)),"^"),NAME=$$GET1^DIQ(2,NN_",",.01,"E")
    130         S SSN=$$GET1^DIQ(2,NN_",",.09)
    131         W !,"Record#: ",SDWLDA,"  Patient: ",NAME," (",SSN,")",!!
    132         Q
    133 GETINS  ;Get institution
    134         N DIR
    135         S DIR("A")="Select Institution: "
    136         S DIR(0)="PAO^4:EMZ",DIR("S")="I $P(^DIC(4,+Y,0),U,11)=""N"",$$TF^XUAF4(+Y)" D ^DIR
    137         I X["^" S SDWLERR=1 Q
    138         I Y<1 W *7,"Invalid Entry" G GETINS
    139         S SDWLINSN=+Y
    140         Q
     1SDWLCU5 ;IOFO BAY PINES/TEH - EWL FILE 409.3 CLEANUP ;2/4/03
     2 ;;5.3;scheduling;**280,427**;AUG 13 1993
     3EN ;
     4 W !!,"Checking file 404.51 one last time.",!
     5 S SDWLERR="",TEAM=0 F  S TEAM=$O(^SCTM(404.51,TEAM)) Q:'TEAM  D  Q:SDWLERR=1
     6 . S INST=$$GET1^DIQ(404.51,TEAM_",",.07,"I")
     7 . S CODE=$$GET1^DIQ(4,INST_",",11,"I")
     8 . S INCK=$$TF^XUAF4(INST)
     9 . I CODE'="N"!('INCK) D
     10 .. W !!,"TEAM: ",$$GET1^DIQ(404.51,TEAM_",",.01),"    INSTITUTION: "
     11 .. W $$GET1^DIQ(4,INST_",",.01)
     12 .. D EDIT^SDWLCU2
     13 Q:SDWLERR=1
     14 ;
     15 W !!,"Checking file 409.31 one last time.",!
     1640931 S SDWLSS=0 F  S SDWLSS=$O(^SDWL(409.31,SDWLSS)) Q:'SDWLSS  D  Q:SDWLERR=1
     17 . S SDWLINS="" F  S SDWLINS=$O(^SDWL(409.31,SDWLSS,"I","B",SDWLINS)) Q:'SDWLINS  D  Q:SDWLERR=1
     18 .. S CODE=$$GET1^DIQ(4,SDWLINS_",",11,"I")
     19 .. S INCK=$$TF^XUAF4(SDWLINS)
     20 .. I CODE'="N"!('INCK) D
     21 ... W !!,"SERVICE SPECIALTY: ",$$GET1^DIQ(409.31,SDWLSS_",",.01),"    INSTITUTION: "
     22 ... W $$GET1^DIQ(4,SDWLINS_",",.01)
     23 ... D GETINS Q:SDWLERR=1
     24 ... S SDWLSSX="" F  S SDWLSSX=$O(^SDWL(409.31,SDWLSS,"I","B",SDWLINS,SDWLSSX)) Q:'SDWLSSX  D  Q:SDWLERR=1
     25 .... D C3^SDWLCU3
     26 Q:SDWLERR=1
     2740932 W !!,"Checking file 409.32 one last time.",!
     28 S SDWLSC=0 F  S SDWLSC=$O(^SDWL(409.32,SDWLSC)) Q:'SDWLSC  D  Q:SDWLERR=1
     29 . S SDWLINS=$$GET1^DIQ(409.32,SDWLSC_",",.02,"I")
     30 . S CODE=$$GET1^DIQ(4,SDWLINS_",",11,"I")
     31 . S INCK=$$TF^XUAF4(SDWLINS)
     32 . I CODE'="N"!('INCK) D
     33 .. W !!,"CLINIC: ",$$GET1^DIQ(409.32,SDWLSC_",",.01),"    INSTITUTION: "
     34 .. W $$GET1^DIQ(4,SDWLINS_",",.01)
     35 .. D GETINS Q:SDWLERR=1
     36 .. K ^SDWL(409.32,"C",+SDWLINS) S $P(^SDWL(409.32,SDWLSC,0),U,6)=SDWLINSN,^SDWL(409.32,"C",SDWLINSN,SDWLSC)=""
     37 .. S SDWLIN(44,+$P(^SDWL(409.32,SDWLSC,0),"^")_",",3)=SDWLINSN D UPDATE^DIE("","SDWLIN","SDWLMSG") K SDWLIN
     38 K ^SDWL(409.32,"ACT") S DIK="^SDWL(409.32," D IXALL^DIK
     39 Q:SDWLERR=1
     40 W !!,"Checking file 409.3 one last time.",!
     41 S SDWLERR=""
     42 S SDWLDA=0,TAG="CHK" F  S SDWLDA=$O(^SDWL(409.3,SDWLDA)) Q:SDWLDA<1  D  Q:SDWLERR=1
     43 .S X=$G(^SDWL(409.3,SDWLDA,0)),SDWLINST=$P(X,"^",3),SDWLTY=$P(X,"^",5)
     44 .Q:'SDWLTY!'SDWLINST
     45 .S SDWLI=$P(X,"^",SDWLTY+5) Q:'SDWLI
     46 .S TAG="CHK",TAG=TAG_SDWLTY,C=0 K ^TMP($J,"SDWLCU5",$J) D @TAG
     47 W !,"Done."
     48 Q
     49CHK1 ;CHECK FOR INSTITUTION VALIDILITY
     50 S SDWLERR=0
     51 I SDWLTY=1 S SDWLI=0 F  S SDWLI=$O(^SCTM(404.51,"AINST",SDWLI)) Q:SDWLI=""  I $D(^DIC(4,SDWLI)) S C=C+1,^TMP($J,"SDWLCU5",$J,C,SDWLI)="",^TMP($J,"SDWLCU5",$J,"B",SDWLI)=""
     52 I $D(^TMP($J,"SDWLCU5",$J,"B",SDWLINST)) Q
     53 K ^TMP($J,"SDWLCU5",$J,"B")
     54 I 'C S SDWLINSN=$S($D(DUZ(2)):DUZ(2),1:"") D CH1E Q
     55 I C=1 S SDWLINSN=$O(^TMP($J,"SDWLCU5",$J,C,0)) D CH1E Q
     56 W !,"Please select a valid Institution for this record from the following list for",!
     57 D DIS
     58 S C=0,SDWLI="" F  S C=$O(^TMP($J,"SDWLCU5",$J,C)) Q:C<1  D
     59 .F  S SDWLI=$O(^TMP($J,"SDWLCU5",$J,C,SDWLI)) Q:SDWLI=""  W !,?20,C,". ",$$GET1^DIQ(4,SDWLI_",",.01) S CS=C
     60CHK10 W ! S DIR(0)="NO^1:"_CS D ^DIR
     61 I Y<1!($D(DUOUT)) W !,"Response Required." S SDWLERR=1 Q
     62 S SDWLINSN=$O(^TMP($J,"SDWLCU5",$J,+Y,0))
     63CH1E S SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLINS","SDWLMSG")
     64 S TAG="CHK"
     65 Q
     66CHK3 ;
     67 S SDWLERR=""
     68 S SDWLI=$P(^SDWL(409.3,SDWLDA,0),U,8)
     69 Q:'SDWLI!'$D(^SDWL(409.31,SDWLI))
     70 I '$D(^SDWL(409.31,SDWLI,"I","B",SDWLINST)) D  Q:SDWLERR=1
     71 .S SDWLIX="",C=0 F  S SDWLIX=$O(^SDWL(409.31,SDWLI,"I","B",SDWLIX)) Q:SDWLIX=""  S C=C+1,^TMP($J,"SDWLCU5",$J,C,SDWLIX)="",^TMP($J,"SDWLCU5",$J,"B",SDWLIX)=""
     72 .I 'C S SDWLINSN=$S($D(DUZ(2)):DUZ(2),1:""),Y=1 D CHE3 Q
     73 .I C=1 S SDWLINSN=$O(^TMP($J,"SDWLCU5",$J,C,0)),Y=1 D CHE3 Q
     74 .W !,"Please select a valid Institution for this record from the following list for",!
     75 .D DIS
     76 .S C=0,SDWLIZ=0 F  S SDWLIZ=$O(^SDWL(409.31,SDWLI,"I","B",SDWLIZ)) Q:SDWLIZ=""  D
     77 ..Q:$$GET1^DIQ(4,SDWLIZ_",",11,"I")'="N"!('$$TF^XUAF4(SDWLIZ))
     78 ..S C=C+1 W !,?20,C,". ",$$GET1^DIQ(4,SDWLIZ_",",.01)
     79 .W ! S DIR(0)="NO^1:"_C D ^DIR
     80 .I $D(DUOUT)!(Y="") S SDWLERR=1 Q
     81 .S SDWLINSN=$O(^TMP($J,"SDWLCU5",$J,+Y,0))
     82 .D CHE3
     83 Q
     84CHE3 ;
     85 G CHK3:Y<0
     86 S SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLINS","SDWLMSG")
     87 S TAG="CHK"
     88 Q
     89CHK4 ;
     90 S SDWLI=$P(^SDWL(409.3,SDWLDA,0),U,9)
     91 Q:'SDWLI!'$D(^SDWL(409.32,SDWLI,0))
     92 I $P(^SDWL(409.32,SDWLI,0),U,6)'=SDWLINST D
     93 .D DIS
     94 .S SDWLINSN=$P(^SDWL(409.32,SDWLI,0),U,6),SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLINS","SDWLMSG")
     95 Q
     96CHK2 ;
     97 S SDWLPO=$P($G(^SDWL(409.3,SDWLDA,0)),U,7),SDWLTM=$P($G(^SCTM(404.57,SDWLPO,0)),U,2),SDWLINSN=$P($G(^SCTM(404.51,SDWLTM,0)),U,7)
     98 I SDWLINST'=SDWLINSN D
     99 .S SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLINS","SDWLMSG")
     100 S TAG="CHK"
     101 Q
     102DIS ;display record
     103 S NN=$P($G(^SDWL(409.3,SDWLDA,0)),"^"),NAME=$$GET1^DIQ(2,NN_",",.01,"E")
     104 S SSN=$$GET1^DIQ(2,NN_",",.09)
     105 W !,"Record#: ",SDWLDA,"  Patient: ",NAME," (",SSN,")",!!
     106 Q
     107GETINS ;Get institution
     108 N DIR
     109 S DIR("A")="Select Institution: "
     110 S DIR(0)="PAO^4:EMZ",DIR("S")="I $P(^DIC(4,+Y,0),U,11)=""N"",$$TF^XUAF4(+Y)" D ^DIR
     111 I X["^" S SDWLERR=1 Q
     112 I Y<1 W *7,"Invalid Entry" G GETINS
     113 S SDWLINSN=+Y
     114 Q

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDWLCU6.m

    r613 r623  
    1 SDWLCU6 ;IOFO BAY PINES/DMR - EWL FILE 409.3 CLEANUP - print ;2/15/05  ; Compiled August 20, 2007 15:12:20
    2         ;;5.3;scheduling;**427,491**;AUG 13 1993;Build 53
    3         N XFL,XFL1,XFLG,XDATA,END,SDWLAPTD,I,J,SDWLPD,SDWLPG,SDWLWD,SDWLTP,SDWLTP1
    4         S (IEN,PAT)="",(CC,SDWLPG,SDWLTP)=0,U="^",END=""
    5         D NOW^%DTC S Y=% D DD^%DT S SDWLDTP=Y
    6         D HD
    7         F  S PAT=$O(^SDWL(409.3,"B",PAT)) Q:PAT=""  D  Q:END
    8         .S IEN="" F  S IEN=$O(^SDWL(409.3,"B",PAT,IEN)) Q:IEN=""  D  Q:END
    9         ..S SDWLX=$G(^SDWL(409.3,IEN,0)),XFLG="",XFL=1,SDWLWD="",SDWLTP1=""
    10         ..F I=3,5,XFL S XDATA=$P(SDWLX,U,I) S:I=5&XDATA XFL=XDATA+5 S:'XDATA XFLG=XFLG_I I I=5,XFL=1 D FIX
    11         ..I XFLG D
    12         ...D HD:$Y+5>IOSL Q:END
    13         ...S NN="",NAME="" S NN=$P($G(^SDWL(409.3,IEN,0)),"^",1),NAME=$$GET1^DIQ(2,NN_",",.01,"E")
    14         ...S SDWLAPTD=$P(SDWLX,U,16) I SDWLAPTD'="" S Y=SDWLAPTD D DD^%DT S SDWLAPTD=Y
    15         ...W !!,IEN,?6,NAME,?40,SDWLAPTD,?54,$P(SDWLX,U,17),?58
    16         ...S XFL="" F I=1:1:3 Q:$E(XFLG,I)=""  S XFL=XFL_$S(XFL'="":",",1:"")_$P("::INST::Type:Team:Postn:Srv/Spec:Clinic",":",$E(XFLG,I))
    17         ...W XFL W:SDWLTP1'="" "/++"
    18         ...W:SDWLWD'="" !,?5,SDWLWD
    19         ...S CC=CC+1
    20         Q:END
    21         IF CC>.5 W !!,"TOTAL null field error EWL entries: "_CC
    22         I SDWLTP>.5 W !!,"++ Missing Wait List Type and corresponding field entry (TEAM,POSITION,",!,"     SERVICE/SPECIALTY,CLINIC). Correct corresponding field entries",!,"     and running report again will correct Wait List Type field"
    23         D CLINIC
    24         W !!,"** End of Report **"
    25         Q
    26 CLINIC  ;Display all clinics in file 409.32 that need to be cleaned up in file 44 in mail message
    27         S INST="",CLINIC=0,CC=0
    28         F  S CLINIC=$O(^SDWL(409.32,CLINIC)) Q:'CLINIC  D
    29         . N CL,INSTST S CL=+$G(^SDWL(409.32,CLINIC,0)) Q:CL'>0
    30         . S INSTST=$$CLIN^SDWLPE(CL)
    31         . I $P(INSTST,U,6)'="" W !,*7,$P(INSTST,U,6) D
    32         .. S CC=CC+1
    33         .. I CC=1 W !!!,"The following clinics need to have the institution updated in file 44:",!!
    34         .. W !,?20,$$GET1^DIQ(44,+$G(^SDWL(409.32,CLINIC,0))_",",.01)
    35         Q
    36 FIX     ;fix corrupted Wait List Type piece 5
    37         S XFL1=0,SDWLTP1=""
    38         F J=6:1:9 S XDATA=$P(SDWLX,U,J) S:XDATA'="" XFL1=J
    39         I 'XFL1 S SDWLTP=SDWLTP+1,SDWLTP1="++" Q
    40         I XFL'=1,XFL=XFL1 Q
    41         S $P(SDWLX,U,5)=XFL1-5,XFL=XFL1,^SDWL(409.3,IEN,0)=SDWLX
    42         S SDWLWD="** WAIT LIST TYPE corrected to value: "_(XFL1-5)_" ("_$P("TEAM;POSITION;SERV/SPCLTY;CLINIC",";",XFL1-5)_")"
    43         Q
    44 HD      ;HDR
    45         I SDWLPG>0,$E(IOST,1,2)="C-" S END=$$EOP^ESPUTIL() Q:END
    46         S SDWLPG=SDWLPG+1 W:SDWLPG'=1 @IOF
    47         W !,?15,"Wait List Key Field 'NULL' Report"
    48         S Y=DT D DD^%DT S SDWLPD=Y W ?57,SDWLPD,?72,"Page: ",SDWLPG
    49         W !!,"STATION: "_+$$SITE^VASITE(,)
    50         W !!,"IEN   Patient Name",?42,"Wait Date",?53,"STS",?58,"Null Fields"
    51         Q
     1SDWLCU6 ;IOFO BAY PINES/DMR - EWL FILE 409.3 CLEANUP - print ;2/15/05
     2 ;;5.3;scheduling;**427**;AUG 13 1993
     3 N XFL,XFL1,XFLG,XDATA,END,SDWLAPTD,I,J,SDWLPD,SDWLPG,SDWLWD,SDWLTP,SDWLTP1
     4 S (IEN,PAT)="",(CC,SDWLPG,SDWLTP)=0,U="^",END=""
     5 D NOW^%DTC S Y=% D DD^%DT S SDWLDTP=Y
     6 D HD
     7 F  S PAT=$O(^SDWL(409.3,"B",PAT)) Q:PAT=""  D  Q:END
     8 .S IEN="" F  S IEN=$O(^SDWL(409.3,"B",PAT,IEN)) Q:IEN=""  D  Q:END
     9 ..S SDWLX=$G(^SDWL(409.3,IEN,0)),XFLG="",XFL=1,SDWLWD="",SDWLTP1=""
     10 ..F I=3,5,XFL S XDATA=$P(SDWLX,U,I) S:I=5&XDATA XFL=XDATA+5 S:'XDATA XFLG=XFLG_I I I=5,XFL=1 D FIX
     11 ..I XFLG D
     12 ...D HD:$Y+5>IOSL Q:END
     13 ...S NN="",NAME="" S NN=$P($G(^SDWL(409.3,IEN,0)),"^",1),NAME=$$GET1^DIQ(2,NN_",",.01,"E")
     14 ...S SDWLAPTD=$P(SDWLX,U,16) I SDWLAPTD'="" S Y=SDWLAPTD D DD^%DT S SDWLAPTD=Y
     15 ...W !!,IEN,?6,NAME,?40,SDWLAPTD,?54,$P(SDWLX,U,17),?58
     16 ...S XFL="" F I=1:1:3 Q:$E(XFLG,I)=""  S XFL=XFL_$S(XFL'="":",",1:"")_$P("::INST::Type:Team:Postn:Srv/Spec:Clinic",":",$E(XFLG,I))
     17 ...W XFL W:SDWLTP1'="" "/++"
     18 ...W:SDWLWD'="" !,?5,SDWLWD
     19 ...S CC=CC+1
     20 Q:END
     21 IF CC>.5 W !!,"TOTAL null field error EWL entries: "_CC
     22 I SDWLTP>.5 W !!,"++ Missing Wait List Type and corresponding field entry (TEAM,POSITION,",!,"     SERVICE/SPECIALTY,CLINIC). Correct corresponding field entries",!,"     and running report again will correct Wait List Type field"
     23 D CLINIC
     24 W !!,"** End of Report **"
     25 Q
     26CLINIC ;Display all clinics in file 409.32 that need to be cleaned up in file 44 in mail message
     27 S INST="",CLINIC=0,CC=0
     28 F  S CLINIC=$O(^SDWL(409.32,CLINIC)) Q:'CLINIC  D
     29 . S INST=$$GET1^DIQ(44,+$G(^SDWL(409.32,CLINIC,0))_",",3,"I")
     30 . I $$GET1^DIQ(4,INST_",",11,"I")'="N"!('$$TF^XUAF4(INST)) D
     31 .. S CC=CC+1
     32 .. I CC=1 W !!!,"The following clinics need to have the institution cleaned in file 44:",!!
     33 .. W !,?20,$$GET1^DIQ(44,+$G(^SDWL(409.32,CLINIC,0))_",",.01)
     34 Q
     35FIX ;fix corrupted Wait List Type piece 5
     36 S XFL1=0,SDWLTP1=""
     37 F J=6:1:9 S XDATA=$P(SDWLX,U,J) S:XDATA'="" XFL1=J
     38 I 'XFL1 S SDWLTP=SDWLTP+1,SDWLTP1="++" Q
     39 I XFL'=1,XFL=XFL1 Q
     40 S $P(SDWLX,U,5)=XFL1-5,XFL=XFL1,^SDWL(409.3,IEN,0)=SDWLX
     41 S SDWLWD="** WAIT LIST TYPE corrected to value: "_(XFL1-5)_" ("_$P("TEAM;POSITION;SERV/SPCLTY;CLINIC",";",XFL1-5)_")"
     42 Q
     43HD ;HDR
     44 I SDWLPG>0,$E(IOST,1,2)="C-" S END=$$EOP^ESPUTIL() Q:END
     45 S SDWLPG=SDWLPG+1 W:SDWLPG'=1 @IOF
     46 W !,?15,"Wait List Key Field 'NULL' Report"
     47 S Y=DT D DD^%DT S SDWLPD=Y W ?57,SDWLPD,?72,"Page: ",SDWLPG
     48 W !!,"STATION: "_DUZ(2)
     49 W !!,"IEN   Patient Name",?42,"Wait Date",?53,"STS",?58,"Null Fields"
     50 Q

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDWLE.m

    r613 r623  
    1 SDWLE   ;BPOI/TEH - WAITING LIST-ENTER/EDIT;06/12/2002
    2         ;;5.3;scheduling;**263,415,446,524**;08/13/93;Build 29
    3         ;
    4         ;
    5         ;******************************************************************
    6         ;                             CHANGE LOG
    7         ;                                               
    8         ;   DATE                        PATCH                   DESCRIPTION
    9         ;   ----                        -----                   -----------
    10         ;   09JUN2005                   446                     Inter-Facility Transfer.
    11         ;   
    12         ;   
    13 EN      ;ENTRY POINT - INTIALIZE VARIABLES
    14         N DTOUT,%
    15         I $D(SDWLOPT),SDWLOPT G OPT
    16         I $D(SDWLLIST),SDWLLIST,$D(DFN),DFN<0 K SDWLLIST
    17         I $D(SDWLLIST),SDWLLIST,$D(DFN),DFN'="" S SDWLDFN=DFN D 1^VADPT S (SDWLTEM,SDWLPOS)=0 D HD,SB1 G EN1:'$D(DUOUT) W !,"PATIENT: ",VADM(1),?40,VA("PID") W !,*7,"PATIENT'S DATE OF DEATH HAS BEEN RECORDED" S DIR(0)="E" D ^DIR G END
    18         K ^TMP("SDWLD",$J) D HD
    19         D PAT G END:DFN<0
    20 OPT     S SDWLPCMM=0,SDWLERR=0 I $D(SDWLOPT),SDWLOPT D
    21         .S %=2 W !,"DO YOU WISH TO PLACE THIS PATIENT ON A WAITING LIST " D YN^DICN
    22         .I %=-1!(%=2) S SDWLERR=1 Q
    23         I $D(SDWLOPT),SDWLOPT,SDWLERR Q
    24         S SDWLDFN=DFN
    25         D 1^VADPT
    26         S (SDWLTEM,SDWLPOS)=0
    27 EN1     N SDWLNEW,SDWLERR,SDWLCN,SDWLWTE S SDWLNEW=0,SDWLERR=0,SDWLCN=0,SDWLWTE=0
    28         G:$$EN^SDWLE6(SDWLDFN,.SDWLERR) EN2  ; OG ; SD*5.3*446 ; Inter-facility transfer
    29         D DIS
    30         I $D(^SDWL(409.3,"B",DFN)),'SDWLCN W !!,"PATIENT: ",VADM(1),?40,VA("PID")
    31         S SDWLPS=$S(SDWLCN>1:1,SDWLCN=1:2,1:3)
    32         I $D(SDWLOPT),SDWLOPT,SDWLPS=3 S X="Y" G ENO
    33         I SDWLPS=1 S DIR(0)="FOA^^" S DIR("A")="Select Wait List (1-"_SDWLCN_") or Enter 'N' for New or '^' to Quit ? ",DIR("?")="Enter a Valid Number or 'N' for New."
    34         I SDWLPS=2 S DIR(0)="FOA^^" S DIR("A")="Select Wait List (1) or Enter 'N' for New or '^' to Quit ? ",DIR("?")="Enter a '1' or 'N' for New."
    35         I SDWLPS=3 S DIR(0)="YAO^^S X=""Y""" S DIR("A")="Patient is not on Waiting List. Do you wish to Add Patient? Yes// "
    36         W ! D ^DIR W ! K DIR
    37         G END:$D(DUOUT),END:$D(DTOUT)
    38         I SDWLPS=1 D  G EN3:SDWLERR=1 I SDWLERR=2 W *7," ??" G EN1
    39         .S SDWLERR=$S(X?1"N".E:0,X?1"n".E:0,X="":2,$D(DUOUT):1,X["^":1,$D(^TMP("SDWLD",$J,DFN,+X)):0,1:2) Q
    40         I SDWLPS=2 D  G EN3:SDWLERR=1 I SDWLERR=2 W *7," ??" G EN1
    41         .S SDWLERR=$S(X?1"N".E:0,X?1"n".E:0,X="":2,$D(DUOUT):1,X["^":1,$D(^TMP("SDWLD",$J,DFN,+X)):0,1:2) Q
    42 ENO     I SDWLPS=3 D  G EN3:SDWLERR=1 I SDWLERR=2 W *7," ??" G EN1
    43         .S SDWLERR=$S(X?1"N".E:1,X?1"n".E:1,X="":0,X?1"Y".E:0,X?1"y".E:0,$D(DUOUT):1,X["^":1,1:2) Q
    44         I SDWLPS=1!(SDWLPS=2),X?1N.N D
    45         .N DA,SDWLDA S (DA,SDWLDA)=$P($G(^TMP("SDWLD",$J,DFN,+X)),"~",2),SDWLEDIT=""
    46         .;
    47         .;LOCK DATA FILE
    48         .;
    49         .L +^SDWL(409.3,DA):5 I '$T W !,"ANOTHER TERMINAL IS EDITING THIS ENTRY. TRY LATER." S DUOUT=1
    50         .I $D(DUOUT) Q
    51         .N SDWLINNM,SDWLSTN  ; OG ; This and the following six lines added for patch 415
    52         .I $$GETTRN^SDWLIFT1(SDWLDA,.SDWLINNM,.SDWLSTN) D  S DUOUT=1 Q
    53         ..N SDWLMSG,SDWLI
    54         ..S SDWLMSG(0)=1,SDWLMSG(SDWLMSG(0),0)="This entry is the subject of a transfer to "_SDWLINNM_" ("_SDWLSTN_"). Editing inhibited."
    55         ..I $L(SDWLMSG(SDWLMSG(0),0))>80 D COL80^SDWLIFT(.SDWLMSG)
    56         ..F SDWLI=1:1:SDWLMSG(0) W !,SDWLMSG(SDWLI,0)
    57         ..Q
    58         .D EN^SDWLE10
    59         .D EDIT W !!,"Editing is Completed" S SDWLERR=1 K SDWLEDIT
    60         G END:SDWLERR
    61         I SDWLPS=1!(SDWLPS=2),X?1"N".E!(X?1"n".E) D NEW,EDIT S SDWLNEW="" G EN2
    62         I SDWLPS=3 D NEW,EDIT S SDWLNEW=""
    63 EN2     I $D(SDWLNEW),'$D(DUOUT),'SDWLERR W !!,?15,"*** Patient has been added to Wait List ***",!
    64         K SDWLNEW,DUOUT
    65         ;
    66         ;UNLOCK FILE AND KILL LOCAL VARIABLES
    67         ;
    68         I $D(SDWLDA) L -^SDWL(409.3,SDWLDA)
    69         ;-exit logic
    70 EN3     D END^SDWLE113
    71         Q
    72 END     D END^SDWLE113
    73         D EN^SDWLKIL
    74         Q
    75         ;
    76         ;
    77 PAT     ;SELECT PATIENT
    78         ;
    79         S DIC(0)="EMNZAQ",DIC=2 D ^DIC S (SDWLDFN,DFN)=$P(Y,U,1) G PAT1:DFN<0
    80         S X=$$GET1^DIQ(2,DFN_",",".351") I X'="" W !,*7,"PATIENT'S DATE OF DEATH HAS BEEN RECORDED" G PAT
    81         S SDWLSSN=$G(VA("PID")),SDWLNAM=$G(VA(1))
    82 PAT1    K VADM,VAIN,VAERR,VA Q
    83         ;
    84 DIS     ;DISPLAY DATA FOR PATIENT
    85         ;
    86         S SDWLHDR="Wait List Enter/Edit"
    87         D EN^SDWLD(DFN,VA("PID"),VADM(1))
    88         D PCM^SDWLE1,PCMD^SDWLE1
    89         Q
    90         ;
    91 NEW     ;
    92         D NEW^SDWLE11
    93         Q
    94         ;
    95 EDIT    ;
    96         D EN^SDWLE111 I $D(DUOUT) D END^SDWLE113:'$D(SDWLEDIT) Q
    97         I SDWLTYE=4 D ED4 K DIR,DIE,DIC,DR Q
    98         I SDWLTYE=3 D ED3 K DIR,DIE,DIC,DR Q
    99         I SDWLTYE=2 D ED2 K DIR,DIE,DIC,DR Q
    100         I SDWLTYE=1 D ED1 K DIR,DIE,DIC,DR Q
    101         Q
    102 ED1     ;-team       
    103         I $D(DUOUT) D END^SDWLE113:'$D(SDWLEDIT) Q
    104         D EN^SDWLE3 I '$D(DUOUT) D EN^SDWLE113 Q
    105         Q
    106 ED2     ;-position
    107         I $D(DUOUT) D END^SDWLE113:'$D(SDWLEDIT) Q
    108         D EN^SDWLE5 I '$D(DUOUT) D EN^SDWLE113 Q
    109         Q
    110 ED3     ;-specialty 
    111         D EN^SDWLE2 I $D(DUOUT) D END^SDWLE113:'$D(SDWLEDIT) Q
    112         D EN^SDWLE110 I $D(DUOUT) D END^SDWLE113:'$D(SDWLEDIT) Q
    113         I '$D(DUOUT) D EN^SDWLE113
    114         D END^SDWLE113
    115         Q
    116 ED4     ;-clinic
    117         D EN^SDWLE4 I $D(DUOUT) D END^SDWLE113:'$D(SDWLEDIT) Q
    118         D EN^SDWLE110 I $D(DUOUT) D END^SDWLE113:'$D(SDWLEDIT) Q
    119         I '$D(DUOUT) D EN^SDWLE113
    120         D END^SDWLE113
    121         Q
    122         ;
    123 ED5     D END^SDWLE113
    124         Q
    125 SB1     S X=$$GET1^DIQ(2,DFN_",",".351") I X'="" S DUOUT=""
    126         Q
    127 HD      W:$D(IOF) @IOF W !,?80-$L("Scheduling/PCMM Enter/Edit Wait List")\2,"Scheduling/PCMM Enter/Edit Wait List",!!
    128         I $D(DFN),DFN'="",'$D(^SDWL(409.3,"B",DFN)),$D(SDWLLIST),SDWLLIST D
    129         .W !!,"PATIENT: ",VADM(1),?40,VA("PID")
    130         Q
     1SDWLE ;;IOFO BAY PINES/TEH - WAITING LIST-ENTER/EDIT;06/12/2002 ; 20 Aug 2002  2:10 PM
     2 ;;5.3;scheduling;**263,446**;AUG 13 1993;Build 77
     3 ;
     4 ;
     5 ;******************************************************************
     6 ;                             CHANGE LOG
     7 ;                                               
     8 ;   DATE                        PATCH                   DESCRIPTION
     9 ;   ----                        -----                   -----------
     10 ;   09JUN2005                   446                     Inter-Facility Transfer.
     11 ;   
     12 ;   
     13EN ;ENTRY POINT - INTIALIZE VARIABLES
     14 N DTOUT,%
     15 I $D(SDWLOPT),SDWLOPT G OPT
     16 I $D(SDWLLIST),SDWLLIST,$D(DFN),DFN<0 K SDWLLIST
     17 I $D(SDWLLIST),SDWLLIST,$D(DFN),DFN'="" S SDWLDFN=DFN D 1^VADPT S (SDWLTEM,SDWLPOS)=0 D HD,SB1 G EN1:'$D(DUOUT) W !,"PATIENT: ",VADM(1),?40,VA("PID") W !,*7,"PATIENT'S DATE OF DEATH HAS BEEN RECORDED" S DIR(0)="E" D ^DIR G END
     18 K ^TMP("SDWLD",$J) D HD
     19 D PAT G END:DFN<0
     20OPT S SDWLPCMM=0,SDWLERR=0 I $D(SDWLOPT),SDWLOPT D
     21 .S %=2 W !,"DO YOU WISH TO PLACE THIS PATIENT ON A WAITING LIST " D YN^DICN
     22 .I %=-1!(%=2) S SDWLERR=1 Q
     23 I $D(SDWLOPT),SDWLOPT,SDWLERR Q
     24 S SDWLDFN=DFN
     25 D 1^VADPT
     26 S (SDWLTEM,SDWLPOS)=0
     27EN1 N SDWLNEW,SDWLERR,SDWLCN,SDWLWTE S SDWLNEW=0,SDWLERR=0,SDWLCN=0,SDWLWTE=0
     28 G:$$EN^SDWLE6(SDWLDFN,.SDWLERR) EN2  ; OG ; SD*5.3*446 ; Inter-facility transfer
     29 D DIS
     30 I $D(^SDWL(409.3,"B",DFN)),'SDWLCN W !!,"PATIENT: ",VADM(1),?40,VA("PID")
     31 S SDWLPS=$S(SDWLCN>1:1,SDWLCN=1:2,1:3)
     32 I $D(SDWLOPT),SDWLOPT,SDWLPS=3 S X="Y" G ENO
     33 I SDWLPS=1 S DIR(0)="FOA^^" S DIR("A")="Select Wait List (1-"_SDWLCN_") or Enter 'N' for New or '^' to Quit ? ",DIR("?")="Enter a Valid Number or 'N' for New."
     34 I SDWLPS=2 S DIR(0)="FOA^^" S DIR("A")="Select Wait List (1) or Enter 'N' for New or '^' to Quit ? ",DIR("?")="Enter a '1' or 'N' for New."
     35 I SDWLPS=3 S DIR(0)="YAO^^S X=""Y""" S DIR("A")="Patient is not on Waiting List. Do you wish to Add Patient? Yes// "
     36 W ! D ^DIR W ! K DIR
     37 G END:$D(DUOUT),END:$D(DTOUT)
     38 I SDWLPS=1 D  G EN3:SDWLERR=1 I SDWLERR=2 W *7," ??" G EN1
     39 .S SDWLERR=$S(X?1"N".E:0,X?1"n".E:0,X="":2,$D(DUOUT):1,X["^":1,$D(^TMP("SDWLD",$J,DFN,+X)):0,1:2) Q
     40 I SDWLPS=2 D  G EN3:SDWLERR=1 I SDWLERR=2 W *7," ??" G EN1
     41 .S SDWLERR=$S(X?1"N".E:0,X?1"n".E:0,X="":2,$D(DUOUT):1,X["^":1,$D(^TMP("SDWLD",$J,DFN,+X)):0,1:2) Q
     42ENO I SDWLPS=3 D  G EN3:SDWLERR=1 I SDWLERR=2 W *7," ??" G EN1
     43 .S SDWLERR=$S(X?1"N".E:1,X?1"n".E:1,X="":0,X?1"Y".E:0,X?1"y".E:0,$D(DUOUT):1,X["^":1,1:2) Q
     44 I SDWLPS=1!(SDWLPS=2),X?1N.N D
     45 .N DA,SDWLDA S (DA,SDWLDA)=$P($G(^TMP("SDWLD",$J,DFN,+X)),"~",2),SDWLEDIT=""
     46 .;
     47 .;LOCK DATA FILE
     48 .;
     49 .L +^SDWL(409.3,DA):5 I '$T W !,"ANOTHER TERMINAL IS EDITING THIS ENTRY. TRY LATER." S DUOUT=1
     50 .I $D(DUOUT) Q
     51 .N SDWLINNM,SDWLSTN  ; OG ; This and the following six lines added for patch 415
     52 .I $$GETTRN^SDWLIFT1(SDWLDA,.SDWLINNM,.SDWLSTN) D  S DUOUT=1 Q
     53 ..N SDWLMSG,SDWLI
     54 ..S SDWLMSG(0)=1,SDWLMSG(SDWLMSG(0),0)="This entry is the subject of a transfer to "_SDWLINNM_" ("_SDWLSTN_"). Editing inhibited."
     55 ..I $L(SDWLMSG(SDWLMSG(0),0))>80 D COL80^SDWLIFT(.SDWLMSG)
     56 ..F SDWLI=1:1:SDWLMSG(0) W !,SDWLMSG(SDWLI,0)
     57 ..Q
     58 .D EN^SDWLE10
     59 .D EDIT W !!,"Editing is Completed" S SDWLERR=1 K SDWLEDIT
     60 G END:SDWLERR
     61 I SDWLPS=1!(SDWLPS=2),X?1"N".E!(X?1"n".E) D NEW,EDIT S SDWLNEW="" G EN2
     62 I SDWLPS=3 D NEW,EDIT S SDWLNEW=""
     63EN2 I $D(SDWLNEW),'$D(DUOUT),'SDWLERR W !!,?15,"*** Patient has been added to Wait List ***",!
     64 K SDWLNEW,DUOUT
     65 ;
     66 ;UNLOCK FILE AND KILL LOCAL VARIABLES
     67 ;
     68 I $D(SDWLDA) L -^SDWL(409.3,SDWLDA)
     69 ;-exit logic
     70EN3 D END^SDWLE113
     71 Q
     72END D END^SDWLE113
     73 D EN^SDWLKIL
     74 Q
     75 ;
     76 ;
     77PAT ;SELECT PATIENT
     78 ;
     79 S DIC(0)="EMNZAQ",DIC=2 D ^DIC S (SDWLDFN,DFN)=$P(Y,U,1) G PAT1:DFN<0
     80 S X=$$GET1^DIQ(2,DFN_",",".351") I X'="" W !,*7,"PATIENT'S DATE OF DEATH HAS BEEN RECORDED" G PAT
     81 S SDWLSSN=$G(VA("PID")),SDWLNAM=$G(VA(1))
     82PAT1 K VADM,VAIN,VAERR,VA Q
     83 ;
     84DIS ;DISPLAY DATA FOR PATIENT
     85 ;
     86 S SDWLHDR="Wait List Enter/Edit"
     87 D EN^SDWLD(DFN,VA("PID"),VADM(1))
     88 D PCM^SDWLE1,PCMD^SDWLE1
     89 Q
     90 ;
     91NEW ;
     92 D NEW^SDWLE11
     93 Q
     94 ;
     95EDIT ;
     96 D EN^SDWLE111 I $D(DUOUT) D END^SDWLE113:'$D(SDWLEDIT) Q
     97 I SDWLTYE=4 D ED4 K DIR,DIE,DIC,DR Q
     98 I SDWLTYE=3 D ED3 K DIR,DIE,DIC,DR Q
     99 I SDWLTYE=2 D ED2 K DIR,DIE,DIC,DR Q
     100 I SDWLTYE=1 D ED1 K DIR,DIE,DIC,DR Q
     101 Q
     102ED1 ;-team       
     103 I $D(DUOUT) D END^SDWLE113:'$D(SDWLEDIT) Q
     104 D EN^SDWLE3 I '$D(DUOUT) D EN^SDWLE113 Q
     105 Q
     106ED2 ;-position
     107 I $D(DUOUT) D END^SDWLE113:'$D(SDWLEDIT) Q
     108 D EN^SDWLE5 I '$D(DUOUT) D EN^SDWLE113 Q
     109 Q
     110ED3 ;-specialty 
     111 D EN^SDWLE2 I $D(DUOUT) D END^SDWLE113:'$D(SDWLEDIT) Q
     112 D EN^SDWLE110 I $D(DUOUT) D END^SDWLE113:'$D(SDWLEDIT) Q
     113 I '$D(DUOUT) D EN^SDWLE113
     114 D END^SDWLE113
     115 Q
     116ED4 ;-clinic
     117 D EN^SDWLE4 I $D(DUOUT) D END^SDWLE113:'$D(SDWLEDIT) Q
     118 D EN^SDWLE110 I $D(DUOUT) D END^SDWLE113:'$D(SDWLEDIT) Q
     119 I '$D(DUOUT) D EN^SDWLE113
     120 D END^SDWLE113
     121 Q
     122 ;
     123ED5 D END^SDWLE113
     124 Q
     125SB1 S X=$$GET1^DIQ(2,DFN_",",".351") I X'="" S DUOUT=""
     126 Q
     127HD W:$D(IOF) @IOF W !,?80-$L("Scheduling/PCMM Enter/Edit Wait List")\2,"Scheduling/PCMM Enter/Edit Wait List",!!
     128 I $D(DFN),DFN'="",'$D(^SDWL(409.3,"B",DFN)),$D(SDWLLIST),SDWLLIST D
     129 .W !!,"PATIENT: ",VADM(1),?40,VA("PID")
     130 Q

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDWLI.m

    r613 r623  
    1 SDWLI   ;BPOI/TEH - DISPLAY PENDING APPOINTMENTS;6/1/05
    2         ;;5.3;scheduling;**263,327,394,446,524**;08/13/93;Build 29
    3         ;
    4         ;
    5         ;******************************************************************
    6         ;                             CHANGE LOG
    7         ;                                               
    8         ;   DATE               PATCH          DESCRIPTION
    9         ;   ----             -----             -----------
    10         ;   04/22/2005      SD*5.3*327  DISPLAY APPOINTMENT INFORMATION
    11         ;   04/22/2005      SD*5.3*327  UNDEFINED ERROR HD+1
    12         ;   08/07/2006      SD*5.3*446  proceed only when DFN defined
    13         ;   04/14/2006      SD*5.3*446  INTER-FACILITY TRANSFER
    14         ;
    15         ;
    16 EN      ;NEW AND INITIALIZE VARIABLES
    17         S SDWLERR=0
    18         I $D(SDWLLIST),SDWLLIST D  Q:SDWLERR
    19         .I '$G(DFN) S SDWLERR=1 Q
    20         .I $D(DFN),DFN'="",'$D(^SDWL(409.3,"B",DFN)) D HD W *7,!,"This Patient has NO entries on the Electronic Wait List." S DIR(0)="E" D ^DIR S DUOUT=1 Q
    21         I $D(DUOUT) G END
    22         I 'SDWLERR,$D(SDWLLIST),SDWLLIST D 1^VADPT,DEM^VADPT S SDWLDFN=DFN D HD K DIR,DIC,DR,DIE,VADM S (SDWLBDT,SDWLEDT)="" K ^TMP("SDWLI",$J) G EN1
    23         K DIR,DIC,DR,DIE,VADM
    24         S (SDWLBDT,SDWLEDT)="" K ^TMP("SDWLI",$J)
    25         ;
    26         ;OPTION HEADER
    27         ;
    28         D HD
    29         ;
    30         ;PATIENT LOOK-UP FROM WAIT LIST PATIENT FILE (^SDWL(409.3,IEN,0).
    31         ;
    32         D SEL G EN:$D(DUOUT)
    33         D PAT Q:'$D(SDWLDFN)
    34         G END:SDWLDFN<0,END:SDWLDFN=""
    35         Q:$D(DUOUT)
    36 EN1     K DIR,DIC,DR,DIE,SDWLDRG
    37         D GETFILE
    38         D DISP G EN:'$D(DUOUT)
    39         D END
    40         Q
    41 PAT     ;PATIENT LOOK-UP
    42         ;PATCH SD*5.3*524 - SET DIC("S") FOR SCREEN OF OPEN/CLOSED ENTRIES
    43         S DIC("S")="I $D(SDWLY),SDWLY,$P(^SDWL(409.3,+Y,0),U,17)=""O"""
    44         S DIC(0)="EMNQA",DIC=409.3 D ^DIC S (SDWLDFN,DFN)=$P(Y,U,2)
    45         G PATEND:SDWLDFN=""
    46         Q:Y<0
    47         Q:$D(DUOUT)
    48         D 1^VADPT
    49 PATEND  Q
    50         ;
    51         ;PROMPT FOR DISPLAY 'OPEN' WAITING LIST ONLY OR PROMPT FOR BEGINNING AND ENDING DATES
    52         ;
    53 SEL     K SDWLDRG S DIR(0)="Y" S DIR("A")="Do You Want to View Only 'OPEN' Wait Lists",DIR("B")="YES"
    54         S DIR("?")="'Yes' for 'Open' and these Patient Record have not been dispositioned and 'No' for all Records."
    55         W ! D ^DIR S SDWLY=Y W !
    56         I X["^" S DUOUT=1
    57         I SDWLY=0 D SEL1
    58         Q
    59 SEL1    K DIR,%DT(0) S SDWLDISC="",%DT="AE",%DT("A")="Start with Date Entered: " D ^%DT G SEL:Y<1 S SDWLBDT=Y
    60         S %DT(0)=SDWLBDT,%DT("A")="End with Date Entered: " D ^%DT G SEL1:Y<1 S SDWLEDT=Y,SDWLDRG="" K %DT(0),%DT("A")
    61         Q
    62         ;
    63 GETFILE ;GET DATA - OPTIONAL DATE RANGE IF SDWLDBT AND SDWLEDT VALID DATE RANGE
    64         ;
    65         K ^TMP("SDWLI",$J),SDWLDISX S SDWLDA=0,SDWLCNT=0 F  S SDWLDA=$O(^SDWL(409.3,"B",SDWLDFN,SDWLDA)) Q:SDWLDA=""  D
    66         .S SDWLDATA=$G(^SDWL(409.3,SDWLDA,0)) I '$D(SDWLDRG),$P(SDWLDATA,U,17)["C" Q
    67         .I '$P(SDWLDATA,U,3) Q
    68         .N SDWLAPP S SDWLAPP="" I $D(^SDWL(409.3,SDWLDA,"SDAPT")) S SDWLAPP=^("SDAPT") D  ;app data
    69         ..S SDWLAPP=SDWLAPP_"~"_$P(SDWLDATA,U,23)
    70         .N SDOP,SDOP1 S SDOP="" I $D(^SDWL(409.3,SDWLDA,1)) S SDOP=^(1),SDOP1=$$GET1^DIQ(409.3,SDWLDA_",",29),$P(SDOP,U)=SDOP1
    71         .I $D(^SDWL(409.3,SDWLDA,"DIS")) D
    72         ..S SDWLDISX=$G(^SDWL(409.3,SDWLDA,"DIS")),SDWLDIS=$P(SDWLDISX,U,3),SDWLDDUZ=$P(SDWLDISX,U,2)
    73         ..S SDWLDDT=$P(^SDWL(409.3,SDWLDA,"DIS"),U,1)
    74         ..S SDWLDIDT="" I SDWLDDT'="" S SDWLDIDT=$E(SDWLDDT,4,5)_"/"_$E(SDWLDDT,6,7)_"/"_$E(SDWLDDT,2,3)
    75         .I $D(^SDWL(409.3,SDWLDA,"DNR")) D
    76         ..S SDREM=$G(^SDWL(409.3,SDWLDA,"DNR")) S SDREMD=$P(SDWLDATA,U,14),SDREMU=$P(SDWLDATA,U,15)
    77         ..S SDREMDD="" I SDREMD'="" S SDREMDD=$E(SDREMD,4,5)_"/"_$E(SDREMD,6,7)_"/"_$E(SDREMD,2,3)
    78         ..S SDREMR=$$GET1^DIQ(409.3,SDWLDA_",",18),SDREMRC=$$GET1^DIQ(409.3,SDWLDA_",",18.1,"I")
    79         .S SDWLST=$P(SDWLDATA,U,6),SDWLSP=$P(SDWLDATA,U,7),SDWLSS=$P(SDWLDATA,U,8),SDWLSC=$P(SDWLDATA,U,9),SDWLDT=$P(SDWLDATA,U,2)
    80         .S SDWLPROV=$P(SDWLDATA,U,13) I $D(SDWLDRG) D  I SDNOK Q
    81         ..S SDNOK=0
    82         ..I SDWLDT<SDWLBDT!(SDWLDT>SDWLEDT) S SDNOK=1 Q
    83         .;
    84         .;IF STATUS IS CLOSED DO NOT DISPLAY RECORD
    85         .;
    86         .S SDWLCNT=SDWLCNT+1,^TMP("SDWLI",$J,SDWLCNT)=SDWLDATA_"~"_SDWLDA
    87         .I $D(SDWLDISX) D
    88         ..S ^TMP("SDWLI",$J,SDWLCNT,"DIS")=SDWLDIS_"^"_SDWLDDUZ_"^"_SDWLDIDT
    89         ..I SDWLAPP>0 S ^TMP("SDWLI",$J,SDWLCNT,"SDAPT")=SDWLAPP
    90         ..I SDOP'="" S ^TMP("SDWLI",$J,SDWLCNT,"SDOP")=SDOP
    91         .I $D(SDREM) D
    92         ..S ^TMP("SDWLI",$J,SDWLCNT,"REM")=SDREMR_U_SDREMRC_U_SDREMU_U_SDREMDD
    93         .S ^TMP("SDWLI",$J)=SDWLCNT
    94         .K SDWLDISX,SDREM
    95         Q
    96         ;
    97 DISP    ;Display Wait List Data
    98         S (SDWLDT,SDWLCNT,SDWLCN)="",SDWLCT=$G(^TMP("SDWLI",$J)) I 'SDWLCT W !!,"No 'OPEN' Wait List Records to Display.",!! K DIR S DIR(0)="E" D ^DIR S DUOUT="" Q
    99         F  S SDWLCNT=$O(^TMP("SDWLI",$J,SDWLCNT)) Q:SDWLCNT=""  D  I $D(DUOUT) Q
    100         .N SDWLDISX,SDWLR,SDWLCLPT
    101         .I $D(^TMP("SDWLI",$J,SDWLCNT,"DIS")) S SDWLDISX=$G(^TMP("SDWLI",$J,SDWLCNT,"DIS"))
    102         .I $D(^TMP("SDWLI",$J,SDWLCNT,"REM")) S SDWLR=$G(^TMP("SDWLI",$J,SDWLCNT,"REM")) D
    103         ..S SDREMR=$P(SDWLR,U),SDREMRC=$P(SDWLR,U,2),SDREMU=$P(SDWLR,U,3),SDREMDD=$P(SDWLR,U,4)
    104         .S X=$G(^TMP("SDWLI",$J,SDWLCNT)),SDWLDA=$P(X,"~",2),SDWLIN=$P(X,U,3),SDWLCL=$P(X,U,4),SDWLTY=$P(X,U,5),SDWLPRI=$P(X,U,11)
    105         .S SDWLTYP=$S(SDWLTY=1:$P(X,U,6),SDWLTY=2:$P(X,U,7),SDWLTY=3:$P(X,U,8),SDWLTY=4:$P(X,U,9),1:"")
    106         .S SDWLTYN=$S(SDWLTY=1:5,SDWLTY=2:6,SDWLTY=3:7,SDWLTY=4:8),SDWLCOM=$P($P(X,U,18),"~",1)
    107         .S SDWLDUZ=$P(X,U,10),SDWLPRV=$P(X,U,12),SDWLPROV=$P(X,U,13),SDWLX=$P(X,"~",3) D
    108         ..I $D(SDWLDISX) S SDWLDIS=$P(SDWLDISX,U,1),SDWLDDUZ=$P(SDWLDISX,U,2),SDWLDIDT=$P(SDWLDISX,U,3)
    109         .S SDWLDT=$P(X,U,2),YY=$E(SDWLDT,1,3)+1700,YY=$E(YY,3,4),MM=$E(SDWLDT,4,5),DD=$E(SDWLDT,6,7),SDWLDTP=MM_"/"_DD_"/"_YY
    110         .S SDWLDTD=$P(X,U,16),YY=$E(SDWLDTD,1,3)+1700,YY=$E(YY,3,4),MM=$E(SDWLDTD,4,5),DD=$E(SDWLDTD,6,7),SDWLDTD=MM_"/"_DD_"/"_YY
    111         .;PATCH SD*5.3*394 See Note.
    112         .N SDWLSCP
    113         .S SDWLSCP=+$P($G(^SDWL(409.3,SDWLDA,"SC")),U,2)
    114         .W !,"# ",$J(SDWLCNT,3),!
    115         .W !,"Wait List - ",$$EXTERNAL^DILFD(409.3,4,,SDWLTY),?55,"Date Entered - ",SDWLDTP
    116         .W !,?15 S X=$$EXTERNAL^DILFD(409.3,SDWLTYN,,SDWLTYP) W X
    117         .S SDWLP=0 I SDWLPRI W !,"Priority - ",$$EXTERNAL^DILFD(409.3,10,,SDWLPRI) S SDWLP=1
    118         .I $D(SDWLSCP) W !,"Service Connected Priority - ",$$EXTERNAL^DILFD(409.3,15,,SDWLSCP)
    119         .W:SDWLP ?15 W:'SDWLP ! W "Institution - ",$$EXTERNAL^DILFD(409.3,2,,SDWLIN)
    120         .W !,"Entered by - " S X=$$EXTERNAL^DILFD(409.3,9,,SDWLDUZ) W X
    121         .S SDWRB=0 I SDWLPRV W !,"Requested By - ",$$EXTERNAL^DILFD(409.3,11,,SDWLPRV),?55,"Date Desired - ",SDWLDTD
    122         .I SDWLPRV=1 W !,"Provider - ",$$EXTERNAL^DILFD(409.3,12,,SDWLPROV)
    123         .I $D(SDWLCOM),SDWLCOM'="" W !,"Comments - ",SDWLCOM
    124         .I $D(^TMP("SDWLI",$J,SDWLCNT,"SDOP")) N SDOP S SDOP=^("SDOP") W !,"Reopen Reason: ",$P(SDOP,U) D
    125         ..I $P(SDOP,U,2)'="" W !,"Reopen comment: ",$P(SDOP,U,2)
    126         .I $D(^TMP("SDWLI",$J,SDWLCNT,"REM")) W !,"Non Removal Reason - ",SDREMR,!,"Non Remove Reason entered by - ",$$GET1^DIQ(200,SDREMU_",",.01,"I") D
    127         ..I $L(SDREMRC)>0 W !,"Non Removal Comment - ",SDREMRC
    128         ..W !,"Non Removal entry date - ",SDREMDD
    129         .I $D(^TMP("SDWLI",$J,SDWLCNT,"DIS")) W !,"Disposition - ",$$EXTERNAL^DILFD(409.3,21,,SDWLDIS),?51,"Disposition Date - ",SDWLDIDT D
    130         ..W !,"Dispositioned by - ",$$EXTERNAL^DILFD(409.3,20,,SDWLDDUZ)
    131         .I $D(^TMP("SDWLI",$J,SDWLCNT,"SDAPT")) N SDAP S SDAP=^("SDAPT") D
    132         ..W !,"Appointment scheduled for " S Y=$P(SDAP,"~",2) D DD^%DT W Y
    133         ..W !?3,"Made on: " S Y=+SDAP D DD^%DT W Y,?30,"For clinic: " N SDC S SDC=$P(SDAP,U,2) S SDC=$$GET1^DIQ(44,SDC_",",.01) W SDC
    134         ..N SDAIN S SDAIN=$P(SDAP,U,3),SDAIN=$$GET1^DIQ(4,SDAIN_",",.01)
    135         ..W !?3,"Appt Institution: ",SDAIN
    136         ..N SDCR S SDCR=$P(SDAP,U,4),SDCR=$$GET1^DIQ(40.7,SDCR_",",.01)
    137         ..W ?40,"Appt Specialty: ",SDCR
    138         ..N SAPS S SAPS=$P(SDAP,U,8),SAPS=$P(SAPS,"~") I SAPS="CC" W !,"Appointment Status: Canceled by Clinic"
    139         .S SDWLCLPT=$$GET1^DIQ(409.3,SDWLDA,37,"I")  ; SD*5.3*446
    140         .D:SDWLCLPT  ; SD*5.3*446
    141         ..W !,"Clinic changed from: ",$$GET1^DIQ(409.3,SDWLCLPT,8)
    142         ..W:SDWLIN'=$$GET1^DIQ(409.3,SDWLCLPT,2,"I") " (",$$GET1^DIQ(409.3,SDWLCLPT,2),")"
    143         ..Q
    144         .; Inter-facility Transfer. SD*5.3*446
    145         .I $$GETTRN^SDWLIFT1(SDWLDA,.SDWLINNM,.SDWLSTN) D ENS^%ZISS W !,IOINHI,"In transfer to ",SDWLINNM," (",SDWLSTN,")",IOINORM D KILL^%ZISS
    146         .D GETS^DIQ(409.3,SDWLDA,"32;33;34;36;38;39","TMP")
    147         .K SDWLIN,SDWLCL,SDWLTY,SDWLPRI,SDWLDUZ,SDWLPRV,SDWLDT,SDWLDTD,SDWLDIS,SDWLDIDT,SDWLTYN,SDWLCOM,SDWLPROV,SDWLDISX,DIR,DIE,DR,SDWLINNM,SDWLSTN
    148         .W !,"*****",! K DIR S DIR(0)="E" D ^DIR  D
    149         ..I X["^" S DUOUT=1 Q
    150         ..I 'Y S DUOUT=1 Q
    151         ..D HD
    152         Q
    153 HD      ;Header
    154         W:$D(IOF) @IOF W !!,?80-$L("Wait List - Inquiry")\2,"Wait List - Inquiry ",!
    155         ;SD*5.3*327 - Correct undefined.
    156         I '$D(SDWLDFN) W !! Q
    157         N DFN S DFN=SDWLDFN D DEM^VADPT
    158         W:$D(VADM) !,VADM(1),?40 I $D(VA("PID")) W VA("PID")
    159         W !!
    160         K DUOUT
    161         Q
    162 END     ;
    163         K DIR,DIC,DR,DIE,SDWLDFN,DUOUT
    164         K SDNOK,SDWLBDT,SDWLCL,SDWLCN,SDWLCNT,SDWLCOM,SDWLCT,SDWLDA,SDWLDATA,SDWLDDT,SDWLDDUZ,SDWLDFN,SDWLDIDT,SDWLDIS,SDWLDISX
    165         K SDWLDRG,SDWLDT,SDWLDTD,SDWLDTP,SDWLDUZ,SDLWEDT,SDWLIN,SDLWP,SDWLPRI,SDWLPROV,SDLWPRV,SDWLSC,SDWLSP,SDWLSS,SDLWST,SDWLTY
    166         K SDWLTYN,SDSWLTYP,SDLWX,SDWLY,SDWRB,SDWLBDT,SDWLDISC,SDWLERR,SDWLPRON,SDXSCAT,SDWLP,SDWLTYP
    167         K SDREMD,SDREMDD,SDREMR,SDREMRC,SDREMU,MM,SDWLEDT,SDWLLIST,SDWLST,SDWLX,VA,X,Y,YY
    168         Q
     1SDWLI ;IOFO BAY PINES/TEH - DISPLAY PENDING APPOINTMENTS ; 6/1/05 12:56pm  ; Compiled April 16, 2007 10:00:47
     2 ;;5.3;scheduling;**263,327,394,446**;AUG 13 1993;Build 77
     3 ;
     4 ;
     5 ;******************************************************************
     6 ;                             CHANGE LOG
     7 ;                                               
     8 ;   DATE               PATCH          DESCRIPTION
     9 ;   ----             -----             -----------
     10 ;   04/22/2005      SD*5.3*327  DISPLAY APPOINTMENT INFORMATION
     11 ;   04/22/2005      SD*5.3*327  UNDEFINED ERROR HD+1
     12 ;   08/07/2006      SD*5.3*446  proceed only when DFN defined
     13 ;   04/14/2006      SD*5.3*446  INTER-FACILITY TRANSFER
     14 ;
     15 ;
     16EN ;NEW AND INITIALIZE VARIABLES
     17 S SDWLERR=0
     18 I $D(SDWLLIST),SDWLLIST D  Q:SDWLERR
     19 .I '$G(DFN) S SDWLERR=1 Q
     20 .I $D(DFN),DFN'="",'$D(^SDWL(409.3,"B",DFN)) D HD W *7,!,"This Patient has NO entries on the Electronic Wait List." S DIR(0)="E" D ^DIR S DUOUT=1 Q
     21 I $D(DUOUT) G END
     22 I 'SDWLERR,$D(SDWLLIST),SDWLLIST D 1^VADPT,DEM^VADPT S SDWLDFN=DFN D HD K DIR,DIC,DR,DIE,VADM S (SDWLBDT,SDWLEDT)="" K ^TMP("SDWLI",$J) G EN1
     23 K DIR,DIC,DR,DIE,VADM
     24 S (SDWLBDT,SDWLEDT)="" K ^TMP("SDWLI",$J)
     25 ;
     26 ;OPTION HEADER
     27 ;
     28 D HD
     29 ;
     30 ;PATIENT LOOK-UP FROM WAIT LIST PATIENT FILE (^SDWL(409.3,IEN,0).
     31 ;
     32 D PAT Q:'$D(SDWLDFN)
     33 G END:SDWLDFN<0,END:SDWLDFN=""
     34 Q:$D(DUOUT)
     35EN1 K DIR,DIC,DR,DIE,SDWLDRG
     36 D SEL G EN:$D(DUOUT)
     37 D GETFILE
     38 D DISP G EN:'$D(DUOUT)
     39 D END
     40 Q
     41PAT ;PATIENT LOOK-UP
     42 S DIC(0)="EMNQA",DIC=409.3 D ^DIC S (SDWLDFN,DFN)=$P(Y,U,2)
     43 G PATEND:SDWLDFN=""
     44 Q:Y<0
     45 Q:$D(DUOUT)
     46 D 1^VADPT
     47PATEND Q
     48 ;
     49 ;PROMPT FOR DISPLAY 'OPEN' WAITING LIST ONLY OR PROMPT FOR BEGINNING AND ENDING DATES
     50 ;
     51SEL K SDWLDRG S DIR(0)="YAO^^" S DIR("A")="Do You Want to View Only 'OPEN' Wait Lists? Yes// "
     52 S DIR("?")="'Yes' for 'Open' and these Patient Record have not been dispositioned and 'No' for all Records."
     53 W ! D ^DIR S SDWLY=Y W !
     54 I X["^" S DUOUT=1
     55 I SDWLY=0 D SEL1
     56 Q
     57SEL1 K DIR,%DT(0) S SDWLDISC="",%DT="AE",%DT("A")="Start with Date Entered: " D ^%DT G SEL:Y<1 S SDWLBDT=Y
     58 S %DT(0)=SDWLBDT,%DT("A")="End with Date Entered: " D ^%DT G SEL1:Y<1 S SDWLEDT=Y,SDWLDRG="" K %DT(0),%DT("A")
     59 Q
     60 ;
     61GETFILE ;GET DATA - OPTIONAL DATE RANGE IF SDWLDBT AND SDWLEDT VALID DATE RANGE
     62 ;
     63 K ^TMP("SDWLI",$J),SDWLDISX S SDWLDA=0,SDWLCNT=0 F  S SDWLDA=$O(^SDWL(409.3,"B",SDWLDFN,SDWLDA)) Q:SDWLDA=""  D
     64 .S SDWLDATA=$G(^SDWL(409.3,SDWLDA,0)) I '$D(SDWLDRG),$P(SDWLDATA,U,17)["C" Q
     65 .I '$P(SDWLDATA,U,3) Q
     66 .N SDWLAPP S SDWLAPP="" I $D(^SDWL(409.3,SDWLDA,"SDAPT")) S SDWLAPP=^("SDAPT") D  ;app data
     67 ..S SDWLAPP=SDWLAPP_"~"_$P(SDWLDATA,U,23)
     68 .N SDOP,SDOP1 S SDOP="" I $D(^SDWL(409.3,SDWLDA,1)) S SDOP=^(1),SDOP1=$$GET1^DIQ(409.3,SDWLDA_",",29),$P(SDOP,U)=SDOP1
     69 .I $D(^SDWL(409.3,SDWLDA,"DIS")) D
     70 ..S SDWLDISX=$G(^SDWL(409.3,SDWLDA,"DIS")),SDWLDIS=$P(SDWLDISX,U,3),SDWLDDUZ=$P(SDWLDISX,U,2)
     71 ..S SDWLDDT=$P(^SDWL(409.3,SDWLDA,"DIS"),U,1)
     72 ..S SDWLDIDT="" I SDWLDDT'="" S SDWLDIDT=$E(SDWLDDT,4,5)_"/"_$E(SDWLDDT,6,7)_"/"_$E(SDWLDDT,2,3)
     73 .I $D(^SDWL(409.3,SDWLDA,"DNR")) D
     74 ..S SDREM=$G(^SDWL(409.3,SDWLDA,"DNR")) S SDREMD=$P(SDWLDATA,U,14),SDREMU=$P(SDWLDATA,U,15)
     75 ..S SDREMDD="" I SDREMD'="" S SDREMDD=$E(SDREMD,4,5)_"/"_$E(SDREMD,6,7)_"/"_$E(SDREMD,2,3)
     76 ..S SDREMR=$$GET1^DIQ(409.3,SDWLDA_",",18),SDREMRC=$$GET1^DIQ(409.3,SDWLDA_",",18.1,"I")
     77 .S SDWLST=$P(SDWLDATA,U,6),SDWLSP=$P(SDWLDATA,U,7),SDWLSS=$P(SDWLDATA,U,8),SDWLSC=$P(SDWLDATA,U,9),SDWLDT=$P(SDWLDATA,U,2)
     78 .S SDWLPROV=$P(SDWLDATA,U,13) I $D(SDWLDRG) D  I SDNOK Q
     79 ..S SDNOK=0
     80 ..I SDWLDT<SDWLBDT!(SDWLDT>SDWLEDT) S SDNOK=1 Q
     81 .;
     82 .;IF STATUS IS CLOSED DO NOT DISPLAY RECORD
     83 .;
     84 .S SDWLCNT=SDWLCNT+1,^TMP("SDWLI",$J,SDWLCNT)=SDWLDATA_"~"_SDWLDA
     85 .I $D(SDWLDISX) D
     86 ..S ^TMP("SDWLI",$J,SDWLCNT,"DIS")=SDWLDIS_"^"_SDWLDDUZ_"^"_SDWLDIDT
     87 ..I SDWLAPP>0 S ^TMP("SDWLI",$J,SDWLCNT,"SDAPT")=SDWLAPP
     88 ..I SDOP'="" S ^TMP("SDWLI",$J,SDWLCNT,"SDOP")=SDOP
     89 .I $D(SDREM) D
     90 ..S ^TMP("SDWLI",$J,SDWLCNT,"REM")=SDREMR_U_SDREMRC_U_SDREMU_U_SDREMDD
     91 .S ^TMP("SDWLI",$J)=SDWLCNT
     92 .K SDWLDISX,SDREM
     93 Q
     94 ;
     95DISP ;Display Wait List Data
     96 S (SDWLDT,SDWLCNT,SDWLCN)="",SDWLCT=$G(^TMP("SDWLI",$J)) I 'SDWLCT W !!,"No 'OPEN' Wait List Records to Display.",!! K DIR S DIR(0)="E" D ^DIR S DUOUT="" Q
     97 F  S SDWLCNT=$O(^TMP("SDWLI",$J,SDWLCNT)) Q:SDWLCNT=""  D  I $D(DUOUT) Q
     98 .N SDWLDISX,SDWLR,SDWLCLPT
     99 .I $D(^TMP("SDWLI",$J,SDWLCNT,"DIS")) S SDWLDISX=$G(^TMP("SDWLI",$J,SDWLCNT,"DIS"))
     100 .I $D(^TMP("SDWLI",$J,SDWLCNT,"REM")) S SDWLR=$G(^TMP("SDWLI",$J,SDWLCNT,"REM")) D
     101 ..S SDREMR=$P(SDWLR,U),SDREMRC=$P(SDWLR,U,2),SDREMU=$P(SDWLR,U,3),SDREMDD=$P(SDWLR,U,4)
     102 .S X=$G(^TMP("SDWLI",$J,SDWLCNT)),SDWLDA=$P(X,"~",2),SDWLIN=$P(X,U,3),SDWLCL=$P(X,U,4),SDWLTY=$P(X,U,5),SDWLPRI=$P(X,U,11)
     103 .S SDWLTYP=$S(SDWLTY=1:$P(X,U,6),SDWLTY=2:$P(X,U,7),SDWLTY=3:$P(X,U,8),SDWLTY=4:$P(X,U,9),1:"")
     104 .S SDWLTYN=$S(SDWLTY=1:5,SDWLTY=2:6,SDWLTY=3:7,SDWLTY=4:8,1:0),SDWLCOM=$P($P(X,U,18),"~",1)
     105 .S SDWLDUZ=$P(X,U,10),SDWLPRV=$P(X,U,12),SDWLPROV=$P(X,U,13),SDWLX=$P(X,"~",3) D
     106 ..I $D(SDWLDISX) S SDWLDIS=$P(SDWLDISX,U,1),SDWLDDUZ=$P(SDWLDISX,U,2),SDWLDIDT=$P(SDWLDISX,U,3)
     107 .S SDWLDT=$P(X,U,2),YY=$E(SDWLDT,1,3)+1700,YY=$E(YY,3,4),MM=$E(SDWLDT,4,5),DD=$E(SDWLDT,6,7),SDWLDTP=MM_"/"_DD_"/"_YY
     108 .S SDWLDTD=$P(X,U,16),YY=$E(SDWLDTD,1,3)+1700,YY=$E(YY,3,4),MM=$E(SDWLDTD,4,5),DD=$E(SDWLDTD,6,7),SDWLDTD=MM_"/"_DD_"/"_YY
     109 .;PATCH SD*5.3*394 See Note.
     110 .N SDWLSCP
     111 .S SDWLSCP=+$P($G(^SDWL(409.3,SDWLDA,"SC")),U,2)
     112 .W !,"# ",$J(SDWLCNT,3),!
     113 .W !,"Wait List - ",$$EXTERNAL^DILFD(409.3,4,,SDWLTY),?55,"Date Entered - ",SDWLDTP
     114 .W !,?15 S X=$$EXTERNAL^DILFD(409.3,SDWLTYN,,SDWLTYP) W X
     115 .S SDWLP=0 I SDWLPRI W !,"Priority - ",$$EXTERNAL^DILFD(409.3,10,,SDWLPRI) S SDWLP=1
     116 .I $D(SDWLSCP) W !,"Service Connected Priority - ",$$EXTERNAL^DILFD(409.3,15,,SDWLSCP)
     117 .W:SDWLP ?15 W:'SDWLP ! W "Institution - ",$$EXTERNAL^DILFD(409.3,2,,SDWLIN)
     118 .W !,"Entered by - " S X=$$EXTERNAL^DILFD(409.3,9,,SDWLDUZ) W X
     119 .S SDWRB=0 I SDWLPRV W !,"Requested By - ",$$EXTERNAL^DILFD(409.3,11,,SDWLPRV),?55,"Date Desired - ",SDWLDTD
     120 .I SDWLPRV=1 W !,"Provider - ",$$EXTERNAL^DILFD(409.3,12,,SDWLPROV)
     121 .I $D(SDWLCOM),SDWLCOM'="" W !,"Comments - ",SDWLCOM
     122 .I $D(^TMP("SDWLI",$J,SDWLCNT,"SDOP")) N SDOP S SDOP=^("SDOP") W !,"Reopen Reason: ",$P(SDOP,U) D
     123 ..I $P(SDOP,U,2)'="" W !,"Reopen comment: ",$P(SDOP,U,2)
     124 .I $D(^TMP("SDWLI",$J,SDWLCNT,"REM")) W !,"Non Removal Reason - ",SDREMR,!,"Non Remove Reason entered by - ",$$GET1^DIQ(200,SDREMU_",",.01,"I") D
     125 ..I $L(SDREMRC)>0 W !,"Non Removal Comment - ",SDREMRC
     126 ..W !,"Non Removal entry date - ",SDREMDD
     127 .I $D(^TMP("SDWLI",$J,SDWLCNT,"DIS")) W !,"Disposition - ",$$EXTERNAL^DILFD(409.3,21,,SDWLDIS),?51,"Disposition Date - ",SDWLDIDT D
     128 ..W !,"Dispositioned by - ",$$EXTERNAL^DILFD(409.3,20,,SDWLDDUZ)
     129 .I $D(^TMP("SDWLI",$J,SDWLCNT,"SDAPT")) N SDAP S SDAP=^("SDAPT") D
     130 ..W !,"Appointment scheduled for " S Y=$P(SDAP,"~",2) D DD^%DT W Y
     131 ..W !?3,"Made on: " S Y=+SDAP D DD^%DT W Y,?30,"For clinic: " N SDC S SDC=$P(SDAP,U,2) S SDC=$$GET1^DIQ(44,SDC_",",.01) W SDC
     132 ..N SDAIN S SDAIN=$P(SDAP,U,3),SDAIN=$$GET1^DIQ(4,SDAIN_",",.01)
     133 ..W !?3,"Appt Institution: ",SDAIN
     134 ..N SDCR S SDCR=$P(SDAP,U,4),SDCR=$$GET1^DIQ(40.7,SDCR_",",.01)
     135 ..W ?40,"Appt Specialty: ",SDCR
     136 ..N SAPS S SAPS=$P(SDAP,U,8),SAPS=$P(SAPS,"~") I SAPS="CC" W !,"Appointment Status: Canceled by Clinic"
     137 .S SDWLCLPT=$$GET1^DIQ(409.3,SDWLDA,37,"I")  ; SD*5.3*446
     138 .D:SDWLCLPT  ; SD*5.3*446
     139 ..W !,"Clinic changed from: ",$$GET1^DIQ(409.3,SDWLCLPT,8)
     140 ..W:SDWLIN'=$$GET1^DIQ(409.3,SDWLCLPT,2,"I") " (",$$GET1^DIQ(409.3,SDWLCLPT,2),")"
     141 ..Q
     142 .; Inter-facility Transfer. SD*5.3*446
     143 .I $$GETTRN^SDWLIFT1(SDWLDA,.SDWLINNM,.SDWLSTN) D ENS^%ZISS W !,IOINHI,"In transfer to ",SDWLINNM," (",SDWLSTN,")",IOINORM D KILL^%ZISS
     144 .D GETS^DIQ(409.3,SDWLDA,"32;33;34;36;38;39","TMP")
     145 .K SDWLIN,SDWLCL,SDWLTY,SDWLPRI,SDWLDUZ,SDWLPRV,SDWLDT,SDWLDTD,SDWLDIS,SDWLDIDT,SDWLTYN,SDWLCOM,SDWLPROV,SDWLDISX,DIR,DIE,DR,SDWLINNM,SDWLSTN
     146 .W !,"*****",! K DIR S DIR(0)="E" D ^DIR  D
     147 ..I X["^" S DUOUT=1 Q
     148 ..I 'Y S DUOUT=1 Q
     149 ..D HD
     150 Q
     151HD ;Header
     152 W:$D(IOF) @IOF W !!,?80-$L("Wait List - Inquiry")\2,"Wait List - Inquiry ",!
     153 ;SD*5.3*327 - Correct undefined.
     154 I '$D(SDWLDFN) W !! Q
     155 N DFN S DFN=SDWLDFN D DEM^VADPT
     156 W:$D(VADM) !,VADM(1),?40 I $D(VA("PID")) W VA("PID")
     157 W !!
     158 K DUOUT
     159 Q
     160END ;
     161 K DIR,DIC,DR,DIE,SDWLDFN,DUOUT
     162 K SDNOK,SDWLBDT,SDWLCL,SDWLCN,SDWLCNT,SDWLCOM,SDWLCT,SDWLDA,SDWLDATA,SDWLDDT,SDWLDDUZ,SDWLDFN,SDWLDIDT,SDWLDIS,SDWLDISX
     163 K SDWLDRG,SDWLDT,SDWLDTD,SDWLDTP,SDWLDUZ,SDLWEDT,SDWLIN,SDLWP,SDWLPRI,SDWLPROV,SDLWPRV,SDWLSC,SDWLSP,SDWLSS,SDLWST,SDWLTY
     164 K SDWLTYN,SDSWLTYP,SDLWX,SDWLY,SDWRB,SDWLBDT,SDWLDISC,SDWLERR,SDWLPRON,SDXSCAT,SDWLP,SDWLTYP
     165 Q

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDWLPE.m

    r613 r623  
    1 SDWLPE  ;IOFO BAY PINES/TEH - WAIT LIST - PARAMETER WAIT LIST ENTER/EDIT ;20 Aug 2002  ; Compiled April 22, 2008 14:13:00
    2         ;;5.3;scheduling;**263,280,288,397,491**;AUG 13 1993;Build 53
    3         ;
    4         ;SD/491 - identify clinic institution through DIVISION ---> INSTITUTION path
    5 EN      ;
    6         ;OPTION HEADER
    7         ;
    8         D HD
    9         ;
    10         ;SELECT FILE TO EDIT
    11         ;
    12 EN1     D SEL G END:X["^",END:X=""
    13         ;
    14         ;EDIT PARAMETER FILE
    15         ;
    16         D EDIT G EN:'$D(Y)
    17         G END
    18         Q
    19         ;
    20 SEL     ;SELECT PARAMETER FILE
    21         S DIR(0)="SO^1:Wait List Service/Specialty File;2:Wait List Clinic Location"
    22         S DIR("L",1)="Select one of the following:"
    23         S DIR("L",2)=""
    24         S DIR("L",3)="    1. Wait List Service/Specialty (409.31)"
    25         S DIR("L")="    2. Wait List Clinic Location (409.32)"
    26         D ^DIR S SDWLF=X
    27         K DIR,DILN,DINDEX
    28         Q
    29 EDIT    ;EDIT FILE PARAMETERS
    30         I SDWLF=1 D SB1 Q:$D(DUOUT)
    31         I SDWLF=2 D SB2 Q:$D(DUOUT)
    32         Q
    33 SB1     S DIC(0)="AEQMZ",DIC("A")="Select DSS ID: ",DIC="^DIC(40.7,",DIC("S")="I '$P(^DIC(40.7,+Y,0),U,3)"
    34         D ^DIC
    35         I X["^" I $D(DA),'$D(^SDWL(409.31,DA,"I")) S DIK="^SDWL(409.31," D ^DIK S DUOUT=1 Q
    36         Q:Y<0  Q:$D(DUOUT)  S SDWLDSS=+Y
    37         I '$D(^SDWL(409.31,"B",SDWLDSS)) D
    38         .S DIC(0)="LX",X=SDWLDSS,DIC="^SDWL(409.31," K DO D FILE^DICN
    39         S DA=$O(^SDWL(409.31,"B",SDWLDSS,""))
    40 SB1A    S DIR(0)="PAO^4:EMZ" D ^DIR
    41         I X="" W *7," Required" G SB1A
    42         I X["^" D:'$D(^SDWL(409.31,DA,"I"))  S DUOUT=1 Q
    43         .S DIK="^SDWL(409.31," D ^DIK
    44         S X=$$GET1^DIQ(4,+Y_",",11)
    45         I X'["N"!'$$TF^XUAF4(+Y) W !,*7,"Invalid Entry. Must be 'National' Institution." G SB1A
    46         I '$D(^SDWL(409.31,DA,"I","B",+Y)) D
    47         .S DA(1)=DA,DIC="^SDWL(409.31,"_DA(1)_","_"""I"""_",",DIC("P")=409.311,X=+Y K D0 D FILE^DICN I +Y S DA=+Y
    48         I $D(^SDWL(409.31,DA,"I","B",+Y)) S DA(1)=DA,DA=$O(^(+Y,0))
    49         K DIC,DIE,DIR,DR
    50         W ! S DR="1;3",DIE="^SDWL(409.31,"_DA(1)_","_"""I"""_"," D ^DIE
    51         I $P(^SDWL(409.31,DA(1),"I",DA,0),U,2)="" D
    52         .W *7,!,"This ENTRY requires an ACTIVATION DATE. ENTRY deleted."
    53         .S DIK="^SDWL(409.31,"_DA(1)_","_"""I"""_"," D ^DIK I '$P(^SDWL(409.31,DA(1),"I",0),U,3) D
    54         ..S DIK="^SDWL(409.31,",DA=DA(1) D ^DIK
    55         K DA,DA(1),SDWLDSS,DIC,DR,DIE,DI,DIEDA,DIG,DIH,DIIENS,DIR,DIU,DIV
    56         Q
    57 SB2     N STR,INST,DIC,SDWLSC,SDWLSTOP S SDWLSTOP=0
    58         W ! S DIC(0)="AEMNZ",DIC("A")="Select Clinic: ",DIC=44
    59         S DIC("S")="S SDWLX=$G(^SC(+Y,0)),SDWLY=$G(^(""I"")) I $P(SDWLX,U,3)=""C"",$P(SDWLY,U,1)'>$P(SDWLY,U,2)"
    60         S DIC("W")="S STR=$$CLIN^SDWLPE(+Y) I STR W ?50,""- "",$E($P(STR,U,3),1,25),""("",$P(STR,U,2),"")"""
    61         D ^DIC I Y<1 K DIC,DA Q
    62         Q:$D(DUOUT)  S SDWLSC=+Y S INST=+STR  ;$$CLIN(SDWLSC)
    63         I $P(STR,U,6)'="" W !,*7,$P(STR,U,6) G SB2
    64         N SDANEW S SDANEW=""
    65         I '$D(^SDWL(409.32,"B",SDWLSC)) D
    66         .S DIC(0)="LX",X=SDWLSC,DIC="^SDWL(409.32," D FILE^DICN
    67         .N DA S DA=$O(^SDWL(409.32,"B",SDWLSC,"")) S SDANEW=DA
    68         .S DIE="^SDWL(409.32,",DR=".02////^S X=INST" D ^DIE
    69         N DA,SDA S DA=$O(^SDWL(409.32,"B",SDWLSC,"")),SDA=DA
    70         S DR="1",DIE="^SDWL(409.32," D ^DIE
    71         I SDANEW,'X D  D ESB2 H 1 G SB2
    72         .W *7,!!,"This ENTRY requires an ACTIVATION DATE. ENTRY deleted."
    73         .S DA=SDANEW S DIK="^SDWL(409.32," D ^DIK
    74         I X S DR="2////^S X=DUZ" D ^DIE
    75         N DIC
    76         S SDWLSCN=$P($G(^SDWL(409.32,SDA,0)),U,1) D  Q:SDWLSTOP
    77         .I $D(^SDWL(409.3,"SC",SDWLSCN)) D
    78         ..S SDWLN="",SDWLCNT=0 F  S SDWLN=$O(^SDWL(409.3,"SC",SDWLSCN,SDWLN)) Q:SDWLN=""  D
    79         ...S X=$G(^SDWL(409.3,SDWLN,0)) I '$D(^SDWL(409.3,SDWLN,"DIS")) S SDWLCNT=SDWLCNT+1,^TMP("SDWLPE",$J,"DIS",SDWLN,SDWLCNT)=X,SDWLSTOP=1
    80         ..I SDWLSTOP W !,"This Clinic has Patients on the Wait List and can not be inactivated."  H 2 Q
    81         .S DR="4////^S X=DUZ" D ^DIE
    82         S DR="3",DIE="^SDWL(409.32," D ^DIE
    83 ESB2    ;
    84         K DR,DIE,DIC,Y,X,SDWLY,DIC(0),DO,DA,DI,DIW,SDWLX,SDWLSCN,SDWLF
    85         Q
    86 SWT     ;SWITCH FOR INACTIVATION OF PARAMETER FILE
    87         Q
    88 HD      ;HEADER
    89         W:$D(IOF) @IOF W !!,?80-$L("Wait List Parameter Enter/Edit")\2,"Wait List Parameter Enter/Edit",!
    90         W !,?80-$L("------------------------------")\2,"------------------------------",!
    91 END     K SDWLSTOP,DIR,DIC,DR,DIK,SDWLX,SDWLSCN,SDWLF,SDWLY,SDWLSC,SDWLN,SDWLCNT,SDWLDSS,DUOUT,X,Y
    92         Q
    93 CLIN(CL)        ;identify clinic institution through DIVISON ----> INSTITUTION path.
    94         ; function to return:
    95         ;                     1                        2                     3               4                    5       6        7
    96         ; - Institution pointer to ^DIC(4 _U_ STATION number (# 99) _U_ INST Name _U_ DIV Pointer to ^DG(40.8 _U_N/L_U_Message_U_TYPE
    97         ;           ( INST^STA NUM^SNAM^DIV^N/L^MESS^TYPE )
    98         ;           N/L - N -National/L -Local
    99         ;           TYPE - type of entry in file # 44 (field #2)
    100         ;                 C:CLINIC
    101         ;                 M:MODULE
    102         ;                 W:WARD
    103         ;                 Z:OTHER LOCATION
    104         ;                 N:NON-CLINIC STOP
    105         ;                 F:FILE AREA
    106         ;                 I:IMAGING
    107         ;                OR:OPERATING ROOM
    108         ;           
    109         ;        with optional Message:
    110         ;       
    111         ;        if STA=""
    112         ;        -  INST^^SNAM^DIV^N/L^' - No Station Number on file' ^ TYPE
    113         ;          or
    114         ;        -  0^^^DIV^^' - No Institution has been identified '^ TYPE
    115         ;        -  0^^^-1^^'  - No Division has been identified' ^ TYPE
    116         ;       
    117         ;        if entry is inactivated:
    118         ;       
    119         ;        -  INST^^SNAM^DIV^N/L^' - Inactive treating medical facility' ^ TYPE
    120         ;        -  -1^^^^^' -  No clinic on file' ^
    121         ;       
    122         I +CL=0!'$D(^SC(+CL)) Q -1_"^^^^^ - No clinic on file^"
    123         N SDWMES,STN,DIV,INS,SNL,STR,SNAM S SDWMES="",STN=""
    124         N TYPE S TYPE=$$GET1^DIQ(44,CL_",",2,"E")
    125         S DIV=+$$GET1^DIQ(44,CL_",",3.5,"I")
    126         I DIV=0 S SDWMES=" - No Division has been identified" Q 0_"^^^"_-1_"^^"_SDWMES_U_TYPE
    127         S INS=+$$GET1^DIQ(40.8,DIV_",",.07,"I")
    128         I INS=0 S SDWMES=" - No Institution has been identified" Q 0_"^^^"_DIV_"^^"_SDWMES_U_TYPE
    129         E  S STR=$$NS^XUAF4(INS),STN=$P(STR,U,2),SNAM=$P(STR,U) ;station number and name
    130         I STN="" S SDWMES=" - No Station Number on file"
    131         I '$$TF^XUAF4(INS) S SDWMES=SDWMES_" - Inactive treating medical facility"
    132         S SNL=$$GET1^DIQ(4,INS_",",11,"I")
    133         Q INS_U_STN_U_SNAM_U_DIV_U_SNL_U_SDWMES_U_TYPE
     1SDWLPE ;IOFO BAY PINES/TEH - WAIT LIST - PARAMETER WAIT LIST ENTER/EDIT ;20 Aug 2002
     2 ;;5.3;scheduling;**263,280,288,397**;AUG 13 1993
     3 ;
     4 ;
     5EN ;
     6 ;OPTION HEADER
     7 ;
     8 D HD
     9 ;
     10 ;SELECT FILE TO EDIT
     11 ;
     12EN1 D SEL G END:X["^",END:X=""
     13 ;
     14 ;EDIT PARAMETER FILE
     15 ;
     16 D EDIT G EN:'$D(Y)
     17 G END
     18 Q
     19 ;
     20SEL ;SELECT PARAMETER FILE
     21 S DIR(0)="SO^1:Wait List Service/Specialty File;2:Wait List Clinic Location"
     22 S DIR("L",1)="Select one of the following:"
     23 S DIR("L",2)=""
     24 S DIR("L",3)="    1. Wait List Service/Specialty (409.31)"
     25 S DIR("L")="    2. Wait List Clinic Location (409.32)"
     26 D ^DIR S SDWLF=X
     27 K DIR,DILN,DINDEX
     28 Q
     29EDIT ;EDIT FILE PARAMETERS
     30 I SDWLF=1 D SB1 Q:$D(DUOUT)
     31 I SDWLF=2 D SB2 Q:$D(DUOUT)
     32 Q
     33SB1 S DIC(0)="AEQMZ",DIC("A")="Select DSS ID: ",DIC="^DIC(40.7,",DIC("S")="I '$P(^DIC(40.7,+Y,0),U,3)"
     34 D ^DIC
     35 I X["^" I $D(DA),'$D(^SDWL(409.31,DA,"I")) S DIK="^SDWL(409.31," D ^DIK S DUOUT=1 Q
     36 Q:Y<0  Q:$D(DUOUT)  S SDWLDSS=+Y
     37 I '$D(^SDWL(409.31,"B",SDWLDSS)) D
     38 .S DIC(0)="LX",X=SDWLDSS,DIC="^SDWL(409.31," K DO D FILE^DICN
     39 S DA=$O(^SDWL(409.31,"B",SDWLDSS,""))
     40SB1A S DIR(0)="PAO^4:EMZ" D ^DIR
     41 I X="" W *7," Required" G SB1A
     42 I X["^" D:'$D(^SDWL(409.31,DA,"I"))  S DUOUT=1 Q
     43 .S DIK="^SDWL(409.31," D ^DIK
     44 S X=$$GET1^DIQ(4,+Y_",",11)
     45 I X'["N"!'$$TF^XUAF4(+Y) W !,*7,"Invalid Entry. Must be 'National' Institution." G SB1A
     46 I '$D(^SDWL(409.31,DA,"I","B",+Y)) D
     47 .S DA(1)=DA,DIC="^SDWL(409.31,"_DA(1)_","_"""I"""_",",DIC("P")=409.311,X=+Y K D0 D FILE^DICN I +Y S DA=+Y
     48 I $D(^SDWL(409.31,DA,"I","B",+Y)) S DA(1)=DA,DA=$O(^(+Y,0))
     49 K DIC,DIE,DIR,DR
     50 W ! S DR="1;3",DIE="^SDWL(409.31,"_DA(1)_","_"""I"""_"," D ^DIE
     51 I $P(^SDWL(409.31,DA(1),"I",DA,0),U,2)="" D
     52 .W *7," This ENTRY requires an ACTIVATION DATE. ENTRY deleted."
     53 .S DIK="^SDWL(409.31,"_DA(1)_","_"""I"""_"," D ^DIK I '$P(^SDWL(409.31,DA(1),"I",0),U,3) D
     54 ..S DIK="^SDWL(409.31,",DA=DA(1) D ^DIK
     55 K DA,DA(1),SDWLDSS,DIC,DR,DIE,DI,DIEDA,DIG,DIH,DIIENS,DIR,DIU,DIV
     56 Q
     57SB2 S SDWLSTOP=0
     58 W ! S DIC(0)="AEQMNZ",DIC("A")="Select Clinic: ",DIC=44
     59 S DIC("S")="S SDWLX=$G(^SC(+Y,0)),SDWLY=$G(^(""I"")) I $P(SDWLX,U,3)=""C"",$P(SDWLY,U,1)'>$P(SDWLY,U,2) I $P(^SC(+Y,0),U,4)"
     60 S DIC("W")="I $P(^SC(+Y,0),U,4) W ?50,""- "",$E($P(^DIC(4,$P(^SC(+Y,0),U,4),0),U,1),1,25)"
     61 D ^DIC Q:Y<1  Q:$D(DUOUT)  S SDWLSC=+Y
     62 S INST=$$GET1^DIQ(44,+Y,3,"I")
     63 S X=$$GET1^DIQ(4,+INST_",",11) I X'["N"!'$$TF^XUAF4(+INST) W !,*7,"Invalid Entry. Must be 'National' Institution." G SB2
     64 I '$D(^SDWL(409.32,"B",SDWLSC)) D
     65 .S DIC(0)="LX",X=SDWLSC,DIC="^SDWL(409.32," D FILE^DICN
     66 S DA=$O(^SDWL(409.32,"B",SDWLSC,""))
     67 K DIC,DIC(0)
     68 S SDWLSCN=$P($G(^SDWL(409.32,DA,0)),U,1) D
     69 .I $D(^SDWL(409.3,"C",SDWLSCN)) D
     70 ..S SDWLN="",SDWLCNT=0 F  S SDWLN=$O(^SDWL(409.3,"C",SDWLSCN,SDWLN)) Q:SDWLN=""  D
     71 ...S X=$G(^SDWL(409.3,SDWLN,0)) I '$D(^SDWL(409.3,SDWLN,"DIS")) S SDWLCNT=SDWLCNT+1,^TMP("SDWLPE",$J,"DIS",SDWLN,SDWLCNT)=X,SDWLSTOP=1
     72 W ! I SDWLSTOP W "This Clinic has Patients on the Wait List and can not be inactivated." Q
     73 S DR="1",DIE="^SDWL(409.32," D ^DIE I X S DR="2////^S X=DUZ" D ^DIE
     74 S DR="3",DIE="^SDWL(409.32," D ^DIE I X S DR="4////^S X=DUZ" D ^DIE
     75 K DR,DIE,DIC,Y,X,SDWLY,DIC(0),DO,DA,DI,DIW,SDWLX,SDWLSCN,SDWLF
     76 Q
     77SWT ;SWITCH FOR INACTIVIATION OF PARAMETER FILE
     78 Q
     79HD ;HEADER
     80 W:$D(IOF) @IOF W !!,?80-$L("Wait List Parameter Enter/Edit")\2,"Wait List Parameter Enter/Edit",!
     81 W !,?80-$L("------------------------------")\2,"------------------------------",!
     82END K SDWLSTOP,DIR,DIC,DR,DIK,SDWLX,SDWLSCN,SDWLF,SDWLY,SDWLSC,SDWLN,SDWLCNT,SDWLDSS,DUOUT,X,Y
     83 Q

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDWLQSR.m

    r613 r623  
    1 SDWLQSR ;BPOI/TEH - WAIT LIST STAT REPORT;06/12/02
    2         ;;5.3;scheduling;**263,425,448,524**;08/13/93;Build 29
    3         ;
    4         ;
    5         ;
    6         ;
    7         ;
    8 EN      N ZCODE,ZTDESC,ZTDTH,ZTIO,ZTQUEDED,ZTREQ,ZTRTN,ZTSAVE,ZTSK,POP
    9         K ^TMP("SDWLQSR",$J)
    10         D HD
    11 1       D INS G END:$D(DUOUT)
    12 2       D DATE G END:$D(DUOUT)
    13 3       D EXCL G END:$D(DUOUT)
    14         D QUE G END:$D(DUOUT)
    15         Q
    16 INS     ;Get Institution
    17         S SDWLERR=0,SDWLPROM="Select Institution ALL // ",SDWLINST=""
    18 IN      W ! S DIC(0)="QEMA",DIC("A")=SDWLPROM,DIC=4,DIC("S")="I $D(^SDWL(409.32,""C"",+Y))!$D(^SDWL(409.31,""E"",+Y))!$D(^SCTM(404.51,""AINST"",+Y))" D ^DIC I Y<0,'SDWLERR Q:$D(DUOUT)  S Y="ALL"
    19         G IN2:Y<0 Q:$D(DUOUT)
    20         I Y<0 S SDWLINST=$S(Y="ALL":"ALL",Y="":"ALL",Y="all":"ALL",Y="All":"ALL",Y["A":"ALL",Y["a":"ALL")
    21         I Y="All"!(Y="")!(Y="all")!(Y="ALL") S SDWLINST="ALL",^TMP("SDWLQSR",$J,"INS")="ALL" G IN3
    22         S SDWLINST=SDWLINST_Y_";",SDWLPROM="Another Institution: ",SDWLERR=1 G IN
    23 IN2     S ^TMP("SDWLQSR",$J,"INS")=SDWLINST
    24 IN3     Q
    25 DATE    ;Date range selection
    26         K X,Y,%DT
    27         S SDWLERR=0 W ! S %DT="AE",%DT("A")="Start Date: " D ^%DT
    28         I X["^" S DUOUT=1 Q
    29         I Y<0 S DUOUT=1 Q
    30         S SDWLBDT=Y
    31         Q:$D(DUOUT)
    32         S %DT("A")="End Date: " D ^%DT G DATE:Y<1 S SDWLEDT=Y K %DT(0),%DT("A")
    33         G DATE:$D(DUOUT)
    34         I SDWLEDT<SDWLBDT W !,"Beginning Date must be greater than Ending Date." G DATE
    35         S ^TMP("SDWLQSR",$J,"DATE")=SDWLBDT_"^"_SDWLEDT K DIR,DIC,DIE,%DT Q
    36         Q
    37 EXCL    ;EXCLUDE # REMAINING =0 - PATCH SD*5.3*524
    38         S SDWLEXCL=0,^TMP("SDWLQSR",$J,"EXCL")=0
    39         S DIR("A",1)="Do you wish to exclude any Teams, Specialities or Specific"
    40         S DIR("A")="Clinics where ALL values are zero"
    41         S DIR("B")="YES",DIR(0)="Y^A0" D ^DIR
    42         I X["^" S DUOUT=1 Q
    43         I Y<0 S DUOUT=1 Q
    44 EXCL1   I Y S SDWLEXCL=1,^TMP("SDWLQSR",$J,"EXCL")=SDWLEXCL
    45         K DIR,X,Y,SDWLEXCL
    46         Q
    47 QUE     ;Queue Report
    48         N ZTQUEUED,POP
    49         K %ZIS,IOP,IOC,ZTIO S %ZIS="MQ" D ^%ZIS G:POP QUE1
    50         S ZTRTN="EN^SDWLRSR",ZTDTH=$H,ZTDESC="WAIT LIST STAT REPORT"
    51         S SDWLTASK="" F  S SDWLTASK=$O(^TMP("SDWLQSR",$J,SDWLTASK)) Q:SDWLTASK=""  D
    52         .S SDWLTK=$G(^TMP("SDWLQSR",$J,SDWLTASK))
    53         .S ZTSAVE(SDWLTASK)=SDWLTK
    54         I $D(IO("Q")) K IO("Q") D ^%ZTLOAD W !,"REQUEST QUEUED" G QUE2
    55 QUE1    S:$E(IOST,1,2)="C-" SDWLSPT=1 I $D(ZTRTN) U IO D @ZTRTN K SDWLSPT
    56         ;
    57         ;
    58 QUE2    K SDWLTASK,SDWLY,SDWLED,WDWLBD,SDWLOPEN,SDWLDATE,SDWLFORM,SDWLPRI
    59         K DIR,DIC,DR,DIE
    60         D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
    61         Q
    62 END     D EN^SDWLKIL
    63         K DUOUT,SDWLBDT,SDWLEDT,SDWLERR,SDWLIST,SDWLPROM,SDWLTK
    64         Q
    65 HD      ;
    66         W:$D(IOF) @IOF W !,?80-$L("Wait List Stat Report")\2,"Wait List Stat Report",!
    67         Q
     1SDWLQSR ;;IOFO BAY PINES/TEH/WAIT LIST STAT REPORT
     2 ;;5.3;scheduling;**263,425,448**;AUG 13 1993
     3 ;
     4 ;
     5 ;
     6 ;
     7 ;
     8EN N ZCODE,ZTDESC,ZTDTH,ZTIO,ZTQUEDED,ZTREQ,ZTRTN,ZTSAVE,ZTSK,POP
     9 D HD
     101 D INS G END:$D(DUOUT)
     112 D DATE G END:$D(DUOUT)
     12 D QUE G END:$D(DUOUT)
     13 Q
     14INS ;Get Institution
     15 S SDWLERR=0,SDWLPROM="Select Institution ALL // ",SDWLINST=""
     16IN W ! S DIC(0)="QEMA",DIC("A")=SDWLPROM,DIC=4,DIC("S")="I $D(^SDWL(409.32,""C"",+Y))!$D(^SDWL(409.31,""E"",+Y))!$D(^SCTM(404.51,""AINST"",+Y))" D ^DIC I Y<0,'SDWLERR Q:$D(DUOUT)  S Y="ALL"
     17 G IN2:Y<0 Q:$D(DUOUT)
     18 I Y<0 S SDWLINST=$S(Y="ALL":"ALL",Y="":"ALL",Y="all":"ALL",Y="All":"ALL",Y["A":"ALL",Y["a":"ALL")
     19 I Y="All"!(Y="")!(Y="all")!(Y="ALL") S SDWLINST="ALL",^TMP("SDWLQSR",$J,"INS")="ALL" G IN3
     20 S SDWLINST=SDWLINST_Y_";",SDWLPROM="Another Institution: ",SDWLERR=1 G IN
     21IN2 S ^TMP("SDWLQSR",$J,"INS")=SDWLINST
     22IN3 Q
     23DATE ;Date range selection
     24 K X,Y,%DT
     25 S SDWLERR=0 W ! S %DT="AE",%DT("A")="Start Date: " D ^%DT
     26 I X["^" S DUOUT=1 Q
     27 I Y<0 S DUOUT=1 Q
     28 S SDWLBDT=Y
     29 Q:$D(DUOUT)
     30 S %DT("A")="End Date: " D ^%DT G DATE:Y<1 S SDWLEDT=Y K %DT(0),%DT("A")
     31 G DATE:$D(DUOUT)
     32 I SDWLEDT<SDWLBDT W !,"Beginning Date must be greater than Ending Date." G DATE
     33 S ^TMP("SDWLQSR",$J,"DATE")=SDWLBDT_"^"_SDWLEDT K DIR,DIC,DIE,%DT Q
     34 Q
     35QUE ;Queue Report
     36 N ZTQUEUED,POP
     37 K %ZIS,IOP,IOC,ZTIO S %ZIS="MQ" D ^%ZIS G:POP QUE1
     38 S ZTRTN="EN^SDWLRSR",ZTDTH=$H,ZTDESC="WAIT LIST STAT REPORT"
     39 S SDWLTASK="" F  S SDWLTASK=$O(^TMP("SDWLQSR",$J,SDWLTASK)) Q:SDWLTASK=""  D
     40 .S SDWLTK=$G(^TMP("SDWLQSR",$J,SDWLTASK))
     41 .S ZTSAVE(SDWLTASK)=SDWLTK
     42 I $D(IO("Q")) K IO("Q") D ^%ZTLOAD W !,"REQUEST QUEUED" G QUE2
     43QUE1 S:$E(IOST,1,2)="C-" SDWLSPT=1 I $D(ZTRTN) U IO D @ZTRTN K SDWLSPT
     44 ;
     45 ;
     46QUE2 K SDWLTASK,SDWLY,SDWLED,WDWLBD,SDWLOPEN,SDWLDATE,SDWLFORM,SDWLPRI
     47 K DIR,DIC,DR,DIE
     48 D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
     49 Q
     50END D EN^SDWLKIL Q
     51HD ;
     52 W:$D(IOF) @IOF W !,?80-$L("Wait List Stat Report")\2,"Wait List Stat Report",!
     53 Q

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDWLREB.m

    r613 r623  
    1 SDWLREB ;BP/ESW - EWL matched with Canceled and Rebooked Appointment by Clinic ; 11/16/05 1:16pm  ; Compiled October 25, 2006 17:29:46
    2         ;;5.3;Scheduling;**467,491**;Aug 13, 1993;Build 53
    3         ;
    4         ;SD*5.3*467 - Match canceled appointments in EWL entries
    5         ;
    6         Q
    7 REBOOK(DFN,SD,SC,RBFLG,SDTRB,SDCAN)     ; rebook section
    8         ;create appt TMP to check for rebooking
    9         ;SD - appt date/time
    10         ;SC - Hospital Location IEN
    11         ;called by reference:
    12         ;       RBFLG - cancellation status from Appointment Multiple
    13         ;                       Only if RBFLG="CCR" - canceled by clinic, rebooked
    14         ;       SDTRB - asked for scheduled Date/Time of Rebooked Appointment
    15         ;       SDCAN - asked for cancellation date/time
    16         N SDARR,SCNT
    17         S RBFLG=0,SDTRB="",SDCAN="NONE" ;initiate if not 'good' appointment
    18         S SDARR(1)=SD_";"_SD
    19         S SDARR(2)=SC
    20         S SDARR(4)=DFN
    21         S SDARR("FLDS")="1;2;3;24;25"
    22         N SAPP S SAPP=$$SDAPI^SDAMA301(.SDARR) D
    23         .N SDINST,SDFAC,SDINSTE
    24         .Q:'$D(^TMP($J,"SDAMA301",DFN))
    25         .N SDSTR S SDSTR=^TMP($J,"SDAMA301",DFN,SC,SD)
    26         .N SDSTAT S SDSTAT=$P(SDSTR,U,3)
    27         .K ^TMP($J,"SDAMA301",DFN,SC,SD)
    28         .S RBFLG=$P(SDSTAT,";")
    29         .S SDTRB=$P(SDSTR,U,24)
    30         .S SDCAN=$P(SDSTR,U,25)
    31         Q
    32 DISREB(DFN,SDTRB,SC)    ;DISPOSITION REBOOK OR NOT
    33         ; DFN - IEN of file #2 (Patient)
    34         ; SDTRB - Scheduled Date/Time of Rebooked Appt
    35         ; SC - Clinic IEN
    36         ; Temporary ^TMP($J,"APPT" will be created with rebooked appt data
    37         N SDARR,SCNT,SDDIV
    38         S SDDIV=""
    39         S SDARR(1)=SDTRB_";"_SDTRB
    40         S SDARR(2)=SC
    41         S SDARR(4)=DFN
    42         S SDARR("FLDS")="1;2;3;4;10;13;14"
    43         N SAPP S SAPP=$$SDAPI^SDAMA301(.SDARR) D
    44         .N SDINST,SDFAC,SDINSTE
    45         .Q:'$D(^TMP($J,"SDAMA301",DFN))
    46         .K ^TMP($J,"APPT") S SCNT=1
    47         .S ^TMP($J,"APPT",SCNT)=^TMP($J,"SDAMA301",DFN,SC,SDTRB)
    48         .N SFAC S SFAC=$$CLIN^SDWLPE(SC) D  ;SD/491
    49         ..S SDINST=+SFAC,SDINSTE=$P(SFAC,U,3),SDFAC=$P(SFAC,U,2)
    50         .S $P(^TMP($J,"APPT",SCNT),"^",15)=SDINST_";"_SDINSTE
    51         .S $P(^TMP($J,"APPT",SCNT),"^",16)=SDFAC
    52         .K ^TMP($J,"SDAMA301",DFN,SC,SDTRB)
    53         Q
    54 OPENEWL(DFN,SDT,SC,SDREB,CEWL)  ; SD*5.3*467 Open EWL entry if closed with appointment being canceled
    55         ;SDT - appointment date/time
    56         ;SC  - appointment clinic IEN
    57         ;SDREB - REBOOKING FLAG: 1 - cancel & rebook
    58         ;                        0 - cancel only
    59         ;CEWL - counter, optionally passed by reference with initial value=0
    60         N DH,IEN,STATUS,CLINIC,WLAPPT,WLSTAT,SDNAM,SDAPPT,SSN,SCN
    61         K ^TMP("SDWLPL",$J),^TMP($J,"SDWLPL")
    62         I '$D(CEWL) D
    63         .I $D(^TMP("SDWLREB",$J)) S CEWL=$O(^TMP("SDWLREB",$J,""),-1)
    64         .E  S CEWL=0
    65         S IEN="" F  S IEN=$O(^SDWL(409.3,"B",DFN,IEN)) Q:IEN<1  D
    66         .S STATUS="" S STATUS=$$GET1^DIQ(409.3,IEN_",",23,"I") IF STATUS="C" D
    67         ..IF $G(^SDWL(409.3,IEN,"SDAPT")) D
    68         ...S CLINIC=$$GET1^DIQ(409.3,IEN_",",13.2,"I"),WLAPPT=$$GET1^DIQ(409.3,IEN_",",13,"I")
    69         ...IF CLINIC=SC&(WLAPPT=SDT) S WLSTAT=$$GET1^DIQ(409.3,IEN_",",21,"I") I WLSTAT="SA" D
    70         ....N Y S Y=WLAPPT D DD^%DT S SDAPPT=Y
    71         ....S SCN=$$GET1^DIQ(44,SC_",",.01),SCN=$E(SCN,1,20)
    72         ....S SDNAM=$$GET1^DIQ(2,DFN_",",.01,"I"),SDNAM=$E(SDNAM,1,25),SSN=$$GET1^DIQ(2,DFN_",",.09,"I")
    73         ....S SDFORM=$$FORM^SDFORM(SDNAM,23,SSN,12,SCN,24,SDAPPT,20)
    74         ....S CEWL=CEWL+1 S ^TMP("SDWLREB",$J,CEWL)=SDFORM
    75         ....N DIE,DA,DR
    76         ....S DIE="^SDWL(409.3,",DA=IEN,DR="23////^S X=""O""" D ^DIE
    77         ....S DR="13.8////^S X=""CC""" D ^DIE
    78         ....S DR="29////^S X=""CA""" D ^DIE
    79         ....S DR="19///@" D ^DIE
    80         ....S DR="20///@" D ^DIE
    81         ....S DR="21///@" D ^DIE
    82         ....S DR="13///@;13.1////@;13.2///@;13.3///@;13.4///@;13.5///@;13.6///@;13.8///@;13.7///@" D ^DIE
    83         ....I $D(^TMP("SDWLREB",$J)) I SDREB D ASKDISP(IEN)
    84         I '$D(^TMP($J,"SDWLPL")) Q  ; no closed EWL related entry
    85         I SDREB D DISP
    86         Q
    87 MESS    ; SD*5.3*467 - send message with a list of opened EWL entries because of canceled appointments
    88         S ^TMP("SDWLREB",$J,.01)="This message displays patients that had their EWL entry opened because of "
    89         S ^TMP("SDWLREB",$J,.02)="their matching appointment being now 'CANCELED BY CLINIC'. Some of those "
    90         S ^TMP("SDWLREB",$J,.03)="entries may be already closed again if new appointments were scheduled and "
    91         S ^TMP("SDWLREB",$J,.04)="matched with those EWL entries. You may use 'SD WAIT LIST REOPEN ENTRIES' "
    92         S ^TMP("SDWLREB",$J,.05)="to run report identifying the related EWL entries."
    93         N SDFORM S SDFORM=$$FORM^SDFORM("PATIENT NAME",23,"SSN",12,"CLINIC",24,"DATE/TIME of APPT",20) D  ;added
    94         .S ^TMP("SDWLREB",$J,.06)=SDFORM
    95         S ^TMP("SDWLREB",$J,.07)="-----------------------------------------------------------------------"
    96         S ^TMP("SDWLREB",$J,.08)=""
    97         N XMSUB,XMY,XMTEXT,XMDUZ
    98         S XMSUB="EWL opened entries with appointments 'CANCELED BY CLINIC'."
    99         S XMY("G.SD EWL BACKGROUND UPDATE")=""
    100         S XMTEXT="^TMP(""SDWLREB"",$J,"
    101         S XMDUZ="POSTMASTER"
    102         D ^XMD K ^TMP("SDWLREB",$J)
    103         Q
    104 ASKDISP(IEN)    ;
    105         ;IEN - pointer to 409.3 to get data and display
    106         N SDDIS S SDDIS=0 ; flag indicating disposition
    107         W ! N X,DIR,DENTER
    108         Q:$$GET1^DIQ(409.3,IEN_",",23,"I")="C"
    109         S ^TMP("SDWLPL",$J,IEN)=$G(^SDWL(409.3,IEN,0)) S DENTER="",DENTER=$P($G(^TMP("SDWLPL",$J,IEN)),"^",2)
    110         S (WLTYPE,TYPE,WLTN,NUM)="",TYPE=$P($G(^TMP("SDWLPL",$J,IEN)),"^",5)
    111         IF DENTER'=""&(TYPE'="") D
    112         .IF TYPE=1 S WLTYPE="PCMM TEAM",NUM=$P($G(^TMP("SDWLPL",$J,IEN)),"^",6),WLTNI=$$GET1^DIQ(404.51,NUM_",",.01,"I"),WLTN=$$GET1^DIQ(404.51,NUM_",",.01)
    113         .IF TYPE=2 S WLTYPE="PCMM POSITION",NUM=$P($G(^TMP("SDWLPL",$J,IEN)),"^",7),WLTNI=$$GET1^DIQ(404.57,NUM_",",.01,"I"),WLTN=$$GET1^DIQ(404.57,NUM_",",.01)
    114         .IF TYPE=3 S WLTYPE="SERV/SPECIALTY",NUM=$P($G(^TMP("SDWLPL",$J,IEN)),"^",8),WLTNI=$$GET1^DIQ(409.31,NUM_",",.01,"I"),WLTN=$$GET1^DIQ(409.31,NUM_",",.01)
    115         .IF TYPE=4 S WLTYPE="CLINIC",NUM=$P($G(^TMP("SDWLPL",$J,IEN)),"^",9),WLTNI=$$GET1^DIQ(409.32,NUM_",",.01,"I"),WLTN=$$GET1^DIQ(409.32,NUM_",",.01)
    116         E  Q
    117         D SAVE(TYPE,WLTNI,IEN)
    118         Q
    119 SAVE(TYPE,WLTNI,IEN)    ;
    120         ;TYPE - EWL type
    121         ;WLTNI - TYPE related name the EWL entry is waiting for
    122         ;IEN - pointer to 409.3
    123         S REQBY=$P($G(^TMP("SDWLPL",$J,IEN)),"^",12)
    124         S INST=$P($G(^TMP("SDWLPL",$J,IEN)),"^",3)
    125         N DESIRED S DESIRED=$P($G(^TMP("SDWLPL",$J,IEN)),"^",16)
    126         N NAME,SSN S NAME=$$GET1^DIQ(2,DFN_",",.01),SSN=$$GET1^DIQ(2,DFN_",",.09)
    127         N SDBY S SDBY=$$GET1^DIQ(409.3,IEN_",",11),SDBY=$E(SDBY,1,3)
    128         S NN=$O(^TMP($J,"SDWLPL",""),-1)+1
    129         S ^TMP($J,"SDWLPL",NN)=IEN_U_WLTYPE_U_U_WLTN_U_INST_U_DENTER_U_SDBY_U_DESIRED
    130         ;
    131         N SPIEC S SPIEC=$S(TYPE=4:9,TYPE=3:10,TYPE=2:11,TYPE=1:12)
    132         S $P(^TMP($J,"SDWLPL",NN),U,SPIEC)=WLTNI
    133         K ^TMP("SDWLPL",$J,IEN)
    134         Q
    135 DISP    ;
    136         W !,"EWL Entry has just been opened because of its matching appointment",!,"being canceled.",!!
    137         N DIR S DIR("B")="YES" ; default to match and close rebooked appointments
    138         S DIR("A")="Do you wish to close this EWL entry with Rebooked Appointment(Yes/No)",DIR(0)="Y"
    139         W "Closing this entry will disposition it: SA - REMOVED/SCHEDULED-ASSIGNED",!,"with Rebooked Appointment.",!!
    140         S DIR("?")="Y(ES) will disposition this EWL entry as 'SA' with just rebooked appointment."
    141         D LIST ; disable displaying EWL entry per SRS.
    142         W ! D ^DIR
    143         N SDDIS S SDDIS=0 I Y S SDDIS=1
    144         E  Q
    145         N SDWLDISP,SDWLDA,SDWLDFN,NUM
    146         I SDDIS S SDWLDISP="SA",NUM="" F  S NUM=$O(^TMP($J,"SDWLPL",NUM)) Q:NUM=""  S REC=^TMP($J,"SDWLPL",NUM) D
    147         .S SDWLDA=+REC N SDP,SDR D
    148         .S DIE="^SDWL(409.3,",DA=SDWLDA,DR="21////^S X=SDWLDISP" D ^DIE
    149         .S DR="19////^S X=DT" D ^DIE
    150         .S DR="20////^S X=DUZ" D ^DIE
    151         .S DR="23////^S X=""C""" D ^DIE
    152         .;I SDWLDISP="SA" update with appointment data
    153         .;get appointment data to file (for a particular appt #)
    154         .I SDWLDISP="SA" N SDA D DATP^SDWLEVAL(1,.SDA) D
    155         ..I $D(SDA) S DIE="^SDWL(409.3,",DA=SDWLDA D
    156         ...S DR="13////"_SDA(1)_";13.1////"_DT_";13.2////"_SDA(2)_";13.3////"_SDA(15)_";13.4////"_SDA(13)_";13.5////"_SDA(14)_";13.6////"_SDA(16)_";13.8////"_SDA(3)_";13.7////"_DUZ
    157         ...D ^DIE
    158         .N SDWLSCL,SDWLSS,SDC
    159         .S SDC=1
    160         .S SDWLSCL=$P($G(^TMP($J,"SDWLPL",SDC)),U,9)
    161         .S SDWLSS=$P($G(^TMP($J,"SDWLPL",SDC)),U,10)
    162         .I SDWLSCL K:$D(^SDWL(409.3,"SC",SDWLSCL,SDWLDA)) ^SDWL(409.3,"SC",SDWLSCL,SDWLDA)
    163         .S SDWLDFN=$P($G(^TMP($J,"APPT",1)),U,4)
    164         .I SDWLSS,SDWLDFN K:$D(^SDWL(409.3,"SS",SDWLDFN,SDWLSS,SDWLDA)) ^SDWL(409.3,"SS",SDWLDFN,SDWLSS,SDWLDA)
    165         Q
    166 LIST    ;LIST
    167         ;may be called if EWL entry display would be needed
    168         S (REC,NUM)="" N SDPN
    169         F  S NUM=$O(^TMP($J,"SDWLPL",NUM)) Q:NUM=""  S REC=^TMP($J,"SDWLPL",NUM) D
    170         .S IEN=+REC N SDP,SDR D
    171         ..S SDPN=$$GET1^DIQ(409.3,IEN_",",.01) W !,"Patient: ",SDPN
    172         ..W !,"  EW List Type   P  Waiting for Institution  Orig Date   By  Des. Date Reopen"
    173         ..W !,"--------------------------------------------------------------------------"
    174         ..S SDP=$E($$GET1^DIQ(409.3,IEN_",",10)) ;priority
    175         ..S SDR=$$GET1^DIQ(409.3,IEN_",",29,"I") ;reopen reason
    176         .N SDINS,SDIN S SDINS=$P(REC,"^",5) S SDIN=$$GET1^DIQ(4,SDINS_",",.01,"I")
    177         .W !,NUM_". ",$E($P(REC,"^",2),1,12),?17,SDP,?21,$E($P(REC,U,4),1,13),?35,SDIN,?45,$$FMTE^XLFDT($P(REC,"^",6),8),?57,$P(REC,"^",7),?61,$$FMTE^XLFDT($P(REC,"^",8),8),?76,SDR
    178         .N SDUP,SDLO
    179         .S SDUP="ABCDEFGHIJKLMNOPRSTUWQXYzv",SDLO="abcdefghijklmnoprstuwqxyzv"
    180         .N SMT S SMT=$$GET1^DIQ(409.3,IEN_",",25) I SMT'="" S SMT=$TR(SMT,SDUP,SDLO) W !?2,"Comment: ",SMT
    181         .N SMO S SMO=$$GET1^DIQ(409.3,IEN_",",30) I SMO'="" S SMO=$TR(SMO,SDUP,SDLO) W !?2,"Reopen: ",SMO
    182         K ANS1,NN,INST,SCODE,CLINIC,DENTER,REQBY,DESIRD,SCPRI
    183         K CLINIC,WLTYPE,TYPE,WLTN,NUM,REC
    184         Q
     1SDWLREB ;BP/ESW - EWL matched with Canceled and Rebooked Appointment by Clinic ; 11/16/05 1:16pm
     2 ;;5.3;Scheduling;**467**;Aug 13, 1993
     3 ;
     4 ;SD*5.3*467 - Match canceled appointments in EWL entries
     5 ;
     6 Q
     7REBOOK(DFN,SD,SC,RBFLG,SDTRB,SDCAN) ; rebook section
     8 ;create appt TMP to check for rebooking
     9 ;SD - appt date/time
     10 ;SC - Hospital Location IEN
     11 ;called by reference:
     12 ;       RBFLG - cancellation status from Appointment Multiple
     13 ;                       Only if RBFLG="CCR" - canceled by clinic, rebooked
     14 ;       SDTRB - asked for scheduled Date/Time of Rebooked Appointment
     15 ;       SDCAN - asked for cancellation date/time
     16 N SDARR,SCNT
     17 S RBFLG=0,SDTRB="",SDCAN="NONE" ;initiate if not 'good' appointment
     18 S SDARR(1)=SD_";"_SD
     19 S SDARR(2)=SC
     20 S SDARR(4)=DFN
     21 S SDARR("FLDS")="1;2;3;24;25"
     22 N SAPP S SAPP=$$SDAPI^SDAMA301(.SDARR) D
     23 .N SDINST,SDFAC,SDINSTE
     24 .Q:'$D(^TMP($J,"SDAMA301",DFN))
     25 .N SDSTR S SDSTR=^TMP($J,"SDAMA301",DFN,SC,SD)
     26 .N SDSTAT S SDSTAT=$P(SDSTR,U,3)
     27 .K ^TMP($J,"SDAMA301",DFN,SC,SD)
     28 .S RBFLG=$P(SDSTAT,";")
     29 .S SDTRB=$P(SDSTR,U,24)
     30 .S SDCAN=$P(SDSTR,U,25)
     31 Q
     32DISREB(DFN,SDTRB,SC) ;DISPOSITION REBOOK OR NOT
     33 ; DFN - IEN of file #2 (Patient)
     34 ; SDTRB - Scheduled Date/Time of Rebooked Appt
     35 ; SC - Clinic IEN
     36 ; Temporary ^TMP($J,"APPT" will be created with rebooked appt data
     37 N SDARR,SCNT
     38 S SDDIV=""
     39 S SDARR(1)=SDTRB_";"_SDTRB
     40 S SDARR(2)=SC
     41 S SDARR(4)=DFN
     42 S SDARR("FLDS")="1;2;3;4;10;13;14"
     43 N SAPP S SAPP=$$SDAPI^SDAMA301(.SDARR) D
     44 .N SDINST,SDFAC,SDINSTE
     45 .Q:'$D(^TMP($J,"SDAMA301",DFN))
     46 .K ^TMP($J,"APPT") S SCNT=1
     47 .S ^TMP($J,"APPT",SCNT)=^TMP($J,"SDAMA301",DFN,SC,SDTRB)
     48 .S SDINST=$$GET1^DIQ(44,SC_",",3,"I")  ; get Institution
     49 .S SDINSTE=$$GET1^DIQ(44,SC_",",3,"E")
     50 .S SDFAC=$S(SDINST="":"",1:$$GET1^DIQ(4,SDINST_",",99,"I"))  ; Station
     51 .I SDFAC="" N SDDIV S SDDIV="" S SDDIV=$$GET1^DIQ(44,SC_",",3.5,"I") D
     52 ..I SDDIV'="" S SDINST=$$GET1^DIQ(40.8,SDDIV_",",.07,"I") I SDINST'="" D
     53 ...S SDFAC=$S(SDINST="":"",1:$$GET1^DIQ(4,SDINST_",",99,"I"))  ; Station
     54 ..I SDDIV="" S SDFAC=$P($$SITE^VASITE(,),"^",3)
     55 .S $P(^TMP($J,"APPT",SCNT),"^",15)=SDINST_";"_SDINSTE
     56 .S $P(^TMP($J,"APPT",SCNT),"^",16)=SDFAC
     57 .K ^TMP($J,"SDAMA301",DFN,SC,SDTRB)
     58 Q
     59OPENEWL(DFN,SDT,SC,SDREB,CEWL) ; SD*5.3*467 Open EWL entry if closed with appointment being canceled
     60 ;SDT - appointment date/time
     61 ;SC  - appointment clinic IEN
     62 ;SDREB - REBOOKING FLAG: 1 - cancel & rebook
     63 ;                        0 - cancel only
     64 ;CEWL - counter, optionally passed by reference with initial value=0
     65 N DH,IEN,STATUS,CLINIC,WLAPPT,WLSTAT,SDNAM,SDAPPT,SSN,SCN
     66 K ^TMP("SDWLPL",$J),^TMP($J,"SDWLPL")
     67 I '$D(CEWL) D
     68 .I $D(^TMP("SDWLREB",$J)) S CEWL=$O(^TMP("SDWLREB",$J,""),-1)
     69 .E  S CEWL=0
     70 S IEN="" F  S IEN=$O(^SDWL(409.3,"B",DFN,IEN)) Q:IEN<1  D
     71 .S STATUS="" S STATUS=$$GET1^DIQ(409.3,IEN_",",23,"I") IF STATUS="C" D
     72 ..IF $G(^SDWL(409.3,IEN,"SDAPT")) D
     73 ...S CLINIC=$$GET1^DIQ(409.3,IEN_",",13.2,"I"),WLAPPT=$$GET1^DIQ(409.3,IEN_",",13,"I")
     74 ...IF CLINIC=SC&(WLAPPT=SDT) S WLSTAT=$$GET1^DIQ(409.3,IEN_",",21,"I") I WLSTAT="SA" D
     75 ....N Y S Y=WLAPPT D DD^%DT S SDAPPT=Y
     76 ....S SCN=$$GET1^DIQ(44,SC_",",.01),SCN=$E(SCN,1,20)
     77 ....S SDNAM=$$GET1^DIQ(2,DFN_",",.01,"I"),SDNAM=$E(SDNAM,1,25),SSN=$$GET1^DIQ(2,DFN_",",.09,"I")
     78 ....S SDFORM=$$FORM^SDFORM(SDNAM,23,SSN,12,SCN,24,SDAPPT,20)
     79 ....S CEWL=CEWL+1 S ^TMP("SDWLREB",$J,CEWL)=SDFORM
     80 ....N DIE,DA,DR
     81 ....S DIE="^SDWL(409.3,",DA=IEN,DR="23////^S X=""O""" D ^DIE
     82 ....S DR="13.8////^S X=""CC""" D ^DIE
     83 ....S DR="29////^S X=""CA""" D ^DIE
     84 ....S DR="19///@" D ^DIE
     85 ....S DR="20///@" D ^DIE
     86 ....S DR="21///@" D ^DIE
     87 ....S DR="13///@;13.1////@;13.2///@;13.3///@;13.4///@;13.5///@;13.6///@;13.8///@;13.7///@" D ^DIE
     88 ....I $D(^TMP("SDWLREB",$J)) I SDREB D ASKDISP(IEN)
     89 I '$D(^TMP($J,"SDWLPL")) Q  ; no closed EWL related entry
     90 I SDREB D DISP
     91 Q
     92MESS ; SD*5.3*467 - send message with a list of opened EWL entries because of canceled appointments
     93 S ^TMP("SDWLREB",$J,.01)="This message displays patients that had their EWL entry opened because of "
     94 S ^TMP("SDWLREB",$J,.02)="their matching appointment being now 'CANCELED BY CLINIC'. Some of those "
     95 S ^TMP("SDWLREB",$J,.03)="entries may be already closed again if new appointments were scheduled and "
     96 S ^TMP("SDWLREB",$J,.04)="matched with those EWL entries. You may use 'SD WAIT LIST REOPEN ENTRIES' "
     97 S ^TMP("SDWLREB",$J,.05)="to run report identifying the related EWL entries."
     98 N SDFORM S SDFORM=$$FORM^SDFORM("PATIENT NAME",23,"SSN",12,"CLINIC",24,"DATE/TIME of APPT",20) D  ;added
     99 .S ^TMP("SDWLREB",$J,.06)=SDFORM
     100 S ^TMP("SDWLREB",$J,.07)="-----------------------------------------------------------------------"
     101 S ^TMP("SDWLREB",$J,.08)=""
     102 N XMSUB,XMY,XMTEXT,XMDUZ
     103 S XMSUB="EWL opened entries with appointments 'CANCELED BY CLINIC'."
     104 S XMY("G.SD EWL BACKGROUND UPDATE")=""
     105 S XMTEXT="^TMP(""SDWLREB"",$J,"
     106 S XMDUZ="POSTMASTER"
     107 D ^XMD K ^TMP("SDWLREB",$J)
     108 Q
     109ASKDISP(IEN) ;
     110 ;IEN - pointer to 409.3 to get data and display
     111 N SDDIS S SDDIS=0 ; flag indicating disposition
     112 W ! N X,DIR,DENTER
     113 Q:$$GET1^DIQ(409.3,IEN_",",23,"I")="C"
     114 S ^TMP("SDWLPL",$J,IEN)=$G(^SDWL(409.3,IEN,0)) S DENTER="",DENTER=$P($G(^TMP("SDWLPL",$J,IEN)),"^",2)
     115 S (WLTYPE,TYPE,WLTN,NUM)="",TYPE=$P($G(^TMP("SDWLPL",$J,IEN)),"^",5)
     116 IF DENTER'=""&(TYPE'="") D
     117 .IF TYPE=1 S WLTYPE="PCMM TEAM",NUM=$P($G(^TMP("SDWLPL",$J,IEN)),"^",6),WLTNI=$$GET1^DIQ(404.51,NUM_",",.01,"I"),WLTN=$$GET1^DIQ(404.51,NUM_",",.01)
     118 .IF TYPE=2 S WLTYPE="PCMM POSITION",NUM=$P($G(^TMP("SDWLPL",$J,IEN)),"^",7),WLTNI=$$GET1^DIQ(404.57,NUM_",",.01,"I"),WLTN=$$GET1^DIQ(404.57,NUM_",",.01)
     119 .IF TYPE=3 S WLTYPE="SERV/SPECIALTY",NUM=$P($G(^TMP("SDWLPL",$J,IEN)),"^",8),WLTNI=$$GET1^DIQ(409.31,NUM_",",.01,"I"),WLTN=$$GET1^DIQ(409.31,NUM_",",.01)
     120 .IF TYPE=4 S WLTYPE="CLINIC",NUM=$P($G(^TMP("SDWLPL",$J,IEN)),"^",9),WLTNI=$$GET1^DIQ(409.32,NUM_",",.01,"I"),WLTN=$$GET1^DIQ(409.32,NUM_",",.01)
     121 E  Q
     122 D SAVE(TYPE,WLTNI,IEN)
     123 Q
     124SAVE(TYPE,WLTNI,IEN) ;
     125 ;TYPE - EWL type
     126 ;WLTNI - TYPE related name the EWL entry is waiting for
     127 ;IEN - pointer to 409.3
     128 S REQBY=$P($G(^TMP("SDWLPL",$J,IEN)),"^",12)
     129 S INST=$P($G(^TMP("SDWLPL",$J,IEN)),"^",3)
     130 N DESIRED S DESIRED=$P($G(^TMP("SDWLPL",$J,IEN)),"^",16)
     131 N NAME,SSN S NAME=$$GET1^DIQ(2,DFN_",",.01),SSN=$$GET1^DIQ(2,DFN_",",.09)
     132 N SDBY S SDBY=$$GET1^DIQ(409.3,IEN_",",11),SDBY=$E(SDBY,1,3)
     133 S NN=$O(^TMP($J,"SDWLPL",""),-1)+1
     134 S ^TMP($J,"SDWLPL",NN)=IEN_U_WLTYPE_U_U_WLTN_U_INST_U_DENTER_U_SDBY_U_DESIRED
     135 ;
     136 N SPIEC S SPIEC=$S(TYPE=4:9,TYPE=3:10,TYPE=2:11,TYPE=1:12)
     137 S $P(^TMP($J,"SDWLPL",NN),U,SPIEC)=WLTNI
     138 K ^TMP("SDWLPL",$J,IEN)
     139 Q
     140DISP ;
     141 W !,"EWL Entry has just been opened because of its matching appointment",!,"being canceled.",!!
     142 N DIR S DIR("B")="YES" ; default to match and close rebooked appointments
     143 S DIR("A")="Do you wish to close this EWL entry with Rebooked Appointment(Yes/No)",DIR(0)="Y"
     144 W "Closing this entry will disposition it: SA - REMOVED/SCHEDULED-ASSIGNED",!,"with Rebooked Appointment.",!!
     145 S DIR("?")="Y(ES) will disposition this EWL entry as 'SA' with just rebooked appointment."
     146 D LIST ; disable displaying EWL entry per SRS.
     147 W ! D ^DIR
     148 N SDDIS S SDDIS=0 I Y S SDDIS=1
     149 E  Q
     150 N SDWLDISP,SDWLDA,SDWLDFN,NUM
     151 I SDDIS S SDWLDISP="SA",NUM="" F  S NUM=$O(^TMP($J,"SDWLPL",NUM)) Q:NUM=""  S REC=^TMP($J,"SDWLPL",NUM) D
     152 .S SDWLDA=+REC N SDP,SDR D
     153 .S DIE="^SDWL(409.3,",DA=SDWLDA,DR="21////^S X=SDWLDISP" D ^DIE
     154 .S DR="19////^S X=DT" D ^DIE
     155 .S DR="20////^S X=DUZ" D ^DIE
     156 .S DR="23////^S X=""C""" D ^DIE
     157 .;I SDWLDISP="SA" update with appointment data
     158 .;get appointment data to file (for a particular appt #)
     159 .I SDWLDISP="SA" N SDA D DATP^SDWLEVAL(1,.SDA) D
     160 ..I $D(SDA) S DIE="^SDWL(409.3,",DA=SDWLDA D
     161 ...S DR="13////"_SDA(1)_";13.1////"_DT_";13.2////"_SDA(2)_";13.3////"_SDA(15)_";13.4////"_SDA(13)_";13.5////"_SDA(14)_";13.6////"_SDA(16)_";13.8////"_SDA(3)_";13.7////"_DUZ
     162 ...D ^DIE
     163 .N SDWLSCL,SDWLSS,SDC
     164 .S SDC=1
     165 .S SDWLSCL=$P($G(^TMP($J,"SDWLPL",SDC)),U,9)
     166 .S SDWLSS=$P($G(^TMP($J,"SDWLPL",SDC)),U,10)
     167 .I SDWLSCL K:$D(^SDWL(409.3,"SC",SDWLSCL,SDWLDA)) ^SDWL(409.3,"SC",SDWLSCL,SDWLDA)
     168 .S SDWLDFN=$P($G(^TMP($J,"APPT",1)),U,4)
     169 .I SDWLSS,SDWLDFN K:$D(^SDWL(409.3,"SS",SDWLDFN,SDWLSS,SDWLDA)) ^SDWL(409.3,"SS",SDWLDFN,SDWLSS,SDWLDA)
     170 Q
     171LIST ;LIST
     172 ;may be called if EWL entry display would be needed
     173 S (REC,NUM)="" N SDPN
     174 F  S NUM=$O(^TMP($J,"SDWLPL",NUM)) Q:NUM=""  S REC=^TMP($J,"SDWLPL",NUM) D
     175 .S IEN=+REC N SDP,SDR D
     176 ..S SDPN=$$GET1^DIQ(409.3,IEN_",",.01) W !,"Patient: ",SDPN
     177 ..W !,"  EW List Type   P  Waiting for Institution  Orig Date   By  Des. Date Reopen"
     178 ..W !,"--------------------------------------------------------------------------"
     179 ..S SDP=$E($$GET1^DIQ(409.3,IEN_",",10)) ;priority
     180 ..S SDR=$$GET1^DIQ(409.3,IEN_",",29,"I") ;reopen reason
     181 .N SDINS,SDIN S SDINS=$P(REC,"^",5) S SDIN=$$GET1^DIQ(4,SDINS_",",.01,"I")
     182 .W !,NUM_". ",$E($P(REC,"^",2),1,12),?17,SDP,?21,$E($P(REC,U,4),1,13),?35,SDIN,?45,$$FMTE^XLFDT($P(REC,"^",6),8),?57,$P(REC,"^",7),?61,$$FMTE^XLFDT($P(REC,"^",8),8),?76,SDR
     183 .N SDUP,SDLO
     184 .S SDUP="ABCDEFGHIJKLMNOPRSTUWQXYzv",SDLO="abcdefghijklmnoprstuwqxyzv"
     185 .N SMT S SMT=$$GET1^DIQ(409.3,IEN_",",25) I SMT'="" S SMT=$TR(SMT,SDUP,SDLO) W !?2,"Comment: ",SMT
     186 .N SMO S SMO=$$GET1^DIQ(409.3,IEN_",",30) I SMO'="" S SMO=$TR(SMO,SDUP,SDLO) W !?2,"Reopen: ",SMO
     187 K ANS1,NN,INST,SCODE,CLINIC,DENTER,REQBY,DESIRD,SCPRI
     188 K CLINIC,WLTYPE,TYPE,WLTN,NUM,REC
     189 Q

  • WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDWLRSR.m

    r613 r623  
    1 SDWLRSR ;BPOI/TEH - WAIT LIST STAT REPORT;10/01/02
    2         ;;5.3;scheduling;**263,273,399,412,425,415,524**;08/13/93;Build 29
    3         ;
    4         ; Removed Sort logic as routine exceeded SACC maximum size of 10000
    5         ; New routine SDWLRSRS was created to perform the Sort functionality
    6         ;
    7         ;
    8 EN      ;
    9         D INIT G END:$D(DUOUT)  ;SD*5.3*415
    10         D SORT^SDWLRSRS(SDWLBD,SDWLED,SDWLINS,.SDWL)  ; SD*5.3*415 new routine to perform sort
    11         D:'$$S^%ZTLOAD PRT  ;SD*5.3*415
    12         G END
    13 INIT    ;
    14         I $D(CT) S SDWLCT2=CT
    15         I $D(DATE) S SDWLDATE=DATE
    16         I $D(INS) S SDWLINS=INS
    17         I $D(EXCL) S SDWLEXCL=EXCL
    18         I $D(ZTSAVE) D
    19         .S SDWLCT=$G(ZTSAVE("CT")),SDWLDATE=$G(ZTSAVE("DATE")),SDWLINS=$G(ZTSAVE("INS")),SDWLEXCL=$G(ZTSAVE("EXCL"))
    20         I SDWLINS'="ALL" F I=1:1 S SDWL=$P(SDWLINS,";",I) Q:SDWL=""  S SDWL("INS",+SDWL)=""
    21         S SDWLBD=$P(SDWLDATE,U,1),SDWLED=$P(SDWLDATE,U,2),SDWLPG=0
    22         D NOW^%DTC S Y=% D DD^%DT S SDWLDTP=Y
    23         N POP S POP=0  ;SD*5.3*412
    24         Q
    25 PRT     ;PRINT REPORT
    26         S (TT1,TT2,TT3,TT4,TT5,TT6,TT7,TT8,TT9,TT10,TT11,TT12,SDWLPG)=0 D HD,HD1 ;SD*5.3*415
    27         I '$D(^TMP("SDWLRSR1")) W !!,"No Wait List Data to Report" Q
    28         S SDWLINS="" F  S SDWLINS=$O(^TMP("SDWLRSR1",$J,SDWLINS)) Q:SDWLINS=""  D  Q:POP  D T2  Q:POP  W !,"________________" I $Y>(IOSL-5) D:$D(SDWLSPT) SCR Q:POP  D HD,HD1  ;SD*5.3*412 added Quit for early exit
    29         .I $$S^%ZTLOAD S DUOUT="" Q
    30         .W !!,"INSTITUTION: ",SDWLINS,! K ^XTMP("SDWLRSR")
    31         .S SDWLTY="" F  S SDWLTY=$O(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY)) Q:SDWLTY=""  D  Q:POP  ;SD*5.3*412 added Quit for early exit
    32         ..S SDWLTNM=$$EXTERNAL^DILFD(409.3,4,,SDWLTY)
    33         ..S SDWLSCN="" F  S SDWLSCN=$O(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN)) Q:SDWLSCN=""  D  Q:POP  ;SD*5.3*412 added Quit for early exit
    34         ...S (T1,T2,T3,T4,T5,T6,T7,T8,T9,T10,T11,T12)=0 ;SD*5.3*415
    35         ...S SDWLSCNM="" F  S SDWLSCNM=$O(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM)) Q:SDWLSCNM=""  D  Q:POP  D T1  Q:POP  ;SD*5.3*412 added Quit
    36         ....S SDWLPRI="" F  S SDWLPRI=$O(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI)) Q:SDWLPRI=""  D  Q:POP  ;SD*5.3*412 added Quit
    37         .....S SDWLFLG=0
    38         .....S SDWLPR=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"PR")) I SDWLEXCL,SDWLPR S SDWLFLG=1
    39         .....S SDWLCL=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"CL")) I 'SDWLFLG,SDWLEXCL,SDWLCL S SDWLFLG=1
    40         .....S SDWLD=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLD")) I 'SDWLFLG,SDWLEXCL,SDWLD S SDWLFLG=1 ;SD*5.3*415
    41         .....S SDWLNC=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLNC")) I 'SDWLFLG,SDWLEXCL,SDWLNC S SDWLFLG=1 ;SD*5.3*415
    42         .....S SDWLSA=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLSA")) I 'SDWLFLG,SDWLEXCL,SDWLSA S SDWLFLG=1 ;SD*5.3*415
    43         .....S SDWLCC=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLCC")) I 'SDWLFLG,SDWLEXCL,SDWLCC S SDWLFLG=1 ;SD*5.3*415
    44         .....S SDWLNN=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLNN")) I 'SDWLFLG,SDWLEXCL,SDWLNN S SDWLFLG=1 ;SD*5.3*415
    45         .....S SDWLER=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLER")) I 'SDWLFLG,SDWLEXCL,SDWLER S SDWLFLG=1 ;SD*5.3*415
    46         .....S SDWLTR=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLTR"))  I 'SDWLFLG,SDWLEXCL,SDWLTR S SDWLFLG=1 ;SD*5.3*415
    47         .....S SDWLAD=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"AD")) I 'SDWLFLG,SDWLEXCL,SDWLAD S SDWLFLG=1 ;SD*5.3*415
    48         .....S SDWLRR=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"RR")) I 'SDWLFLG,SDWLEXCL,SDWLRR S SDWLFLG=1 ;SD*5.3*415
    49         .....S SDWLNR=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"NR")) I 'SDWLFLG,SDWLEXCL,SDWLNR S SDWLFLG=1 ;W ?72,$J(SDWLNR,3)
    50         .....I 'SDWLEXCL,'SDWLFLG S SDWLFG=1
    51         .....I SDWLEXCL,'SDWLFLG Q
    52         .....I '$D(^XTMP("SDWLRSR",$J,SDWLTNM)) W !,$E(SDWLTNM,1,15) S ^XTMP("SDWLRSR",$J,SDWLTNM)=""
    53         .....W !?2,$E(SDWLSCNM_" "_$S(SDWLPRI="A":"ASAP",SDWLPRI="F":"FUTURE",1:""),1,17)
    54         .....S T1=T1+SDWLPR,TT1=TT1+SDWLPR W ?21,$J(SDWLPR,3)
    55         .....S T2=T2+SDWLCL,TT2=TT2+SDWLCL W ?26,$J(SDWLCL,3)
    56         .....S T3=T3+SDWLD,TT3=TT3+SDWLD W ?31,$J(SDWLD,3)
    57         .....S T4=T4+SDWLNC,TT4=TT4+SDWLNC W ?36,$J(SDWLNC,3)
    58         .....S T5=T5+SDWLSA,TT5=TT5+SDWLSA W ?41,$J(SDWLSA,3)
    59         .....S T6=T6+SDWLCC,TT6=TT6+SDWLCC W ?46,$J(SDWLCC,3)
    60         .....S T7=T7+SDWLNN,TT7=TT7+SDWLNN W ?51,$J(SDWLNN,3)
    61         .....S T8=T8+SDWLER,TT8=TT8+SDWLER W ?56,$J(SDWLER,3)
    62         .....S T9=T9+SDWLTR,TT9=TT9+SDWLTR W ?61,$J(SDWLTR,3) ;SD*5.3*415
    63         .....S T10=T10+SDWLAD,TT10=TT10+SDWLAD W ?66,$J(SDWLAD,3) ;SD*5.3*415
    64         .....S T11=T11+SDWLRR,TT11=TT11+SDWLRR W ?71,$J(SDWLRR,3) ;SD*5.3*415
    65         .....S T12=T12+SDWLNR,TT12=TT12+SDWLNR W ?76,$J(SDWLNR,3) ;SD*5.3*415
    66         .....I $Y>(IOSL-5) D:$D(SDWLSPT) SCR Q:POP  D HD,HD1  ;SD*5.3*412
    67         Q
    68 SCR     S DIR(0)="E" D ^DIR S:X="^" POP=1  ;SD*5.3*412
    69         Q
    70 T1      ;
    71         I 'SDWLFLG,SDWLEXCL Q
    72         W !?20,"---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ----"  ;SD*5.3*415
    73         W !,"Sub-Totals:"
    74         ;write sub-totals
    75         W ?21,$J(T1,3),?26,$J(T2,3),?31,$J(T3,3),?36,$J(T4,3),?41,$J(T5,3),?46,$J(T6,3),?51,$J(T7,3),?56,$J(T8,3),?61,$J(T9,3),?66,$J(T10,3),?71,$J(T11,3),?76,$J(T12,3),!  ;SD*5.3*415
    76         S (T1,T2,T3,T4,T5,T6,T7,T8,T9,T10,T11,T12)=0  ;SD*5.3*415
    77         I $Y>(IOSL-5) D:$D(SDWLSPT) SCR Q:POP  D HD,HD1  ;SD*5.3*412
    78         Q
    79 T2      W !,"Institution Totals:"
    80         W ?21,$J(TT1,3),?26,$J(TT2,3),?31,$J(TT3,3),?36,$J(TT4,3),?41,$J(TT5,3),?46,$J(TT6,3),?51,$J(TT7,3),?56,$J(TT8,3),?61,$J(TT9,3),?66,$J(TT10,3),?71,$J(TT11,3),?76,$J(TT12,3),!  ;SD*5.3*415
    81         S (TT1,TT2,TT3,TT4,TT5,TT6,TT7,TT8,TT9,TT10,TT11,TT12)=0  ;SD*5.3*415
    82         I $Y>(IOSL-5) D:$D(SDWLSPT) SCR Q:POP  D HD,HD1  ;SD*5.3*412
    83         Q
    84 HD      W:$D(IOF) @IOF S SDWLPG=SDWLPG+1 W !!,SDWLDTP,?80-$L("Wait List (Sch/PCMM) Stat Report")\2,"Wait List (Sch/PCMM) Stat Report",?65,"Page: ",SDWLPG
    85         W !,?80-$L("STARTED Date: ")\2,"STARTED Date: " S Y=$P(SDWLDATE,U,1) D DD^%DT W Y
    86         W !,?80-$L("FINISHED Date: ")\2,"FINISHED Date: " S Y=$P(SDWLDATE,U,2) D DD^%DT W Y
    87         Q
    88 HD1     ;
    89         W !,?20,"PREV"
    90         W ?65,"#"
    91         W ?75,"# NOT"
    92         W !,"WAIT LIST TYPE"
    93         W ?20,"REMN",?25,"CLSD",?31,"DTH",?37,"NC",?42,"SA",?47,"CC",?52,"NN",?57,"ER",?61,"TR",?65,"ADD",?70,"REMN",?75,"REMVD",!  ;SD*5.3*415
    94         Q
    95 END     D EN^SDWLKIL
    96         K ^TMP("SDWLRSR1",$J),^TMP("SDWLRSR2",$J),SDWLY1,SDWLX1,SDWLRDT,CT,I
    97         K T1,T2,T3,T4,T5,T6,T7,T8,T9,T10,T11,T12,SDWLAD,SDWLBD,SDWLCC,SDWLCT,SDWLDFDT,SDWLDP,SDWLED,SDWLER,SDWLERR,SDWLFLD,X1,X2,DATE  ;SD*5.3*415
    98         K TT1,TT2,TT3,TT4,TT5,TT6,TT7,TT8,TT9,TT10,TT11,TT12,SDWLINSN,SDWLINST,SDWLNC,SDWLNN,SDWLNR,SDWLOFDT,SDWLOK1,SDWLOK2,SDWLTYPN  ;SD*5.3*415
    99         K SDWLOK3,SDWLPR,SDWLPR,SDWLPROM,SDWLRE,SDWLRFDT,SDWLRR,SDWLSA,SDWLSCN,SDWLSCNM,SDWLTASK,SDWLTK,SDWLTNM,SDWLTYNM,SDWLTYP,X4,SDWLTR  ;SD*5.3*415
    100         Q
     1SDWLRSR ;;IOFO BAY PINES/TEH/WAIT LIST STAT REPORT ; 01 Oct 2002  4:42 PM  ; Compiled December 21, 2006 15:32:50
     2 ;;5.3;scheduling;**263,273,399,412,425,415,446**;AUG 13 1993;Build 77
     3 ;
     4 ; Removed Sort logic as routine exceeded SACC maximum size of 10000
     5 ; New routine SDWLRSRS was created to perform the Sort functionality
     6 ;
     7 ;
     8EN ;
     9 D INIT G END:$D(DUOUT)  ;SD*5.3*415
     10 D SORT^SDWLRSRS(SDWLBD,SDWLED,SDWLINS,.SDWL)  ; SD*5.3*415 new routine to perform sort
     11 D:'$$S^%ZTLOAD PRT  ;SD*5.3*415
     12 G END
     13INIT ;
     14 I $D(CT) S SDWLCT2=CT
     15 I $D(DATE) S SDWLDATE=DATE
     16 I $D(INS) S SDWLINS=INS
     17 I $D(ZTSAVE) D
     18 .S SDWLCT=$G(ZTSAVE("CT")),SDWLDATE=$G(ZTSAVE("DATE")),SDWLINS=$G(ZTSAVE("INS"))
     19 I SDWLINS'="ALL" F I=1:1 S SDWL=$P(SDWLINS,";",I) Q:SDWL=""  S SDWL("INS",+SDWL)=""
     20 S SDWLBD=$P(SDWLDATE,U,1),SDWLED=$P(SDWLDATE,U,2),SDWLPG=0
     21 D NOW^%DTC S Y=% D DD^%DT S SDWLDTP=Y
     22 N POP S POP=0  ;SD*5.3*412
     23 Q
     24PRT ;PRINT REPORT
     25 S (T1,T2,T3,T4,T5,T6,T7,T8,T9,T10,T11,T12,T13)=0  ;SD*5.3*446
     26 S (TT1,TT2,TT3,TT4,TT5,TT6,TT7,TT8,TT9,TT10,TT11,TT12,TT13,SDWLPG)=0 D HD,HD1  ;SD*5.3*415,446
     27 I '$D(^TMP("SDWLRSR1")) W !!,"No Wait List Data to Report" Q
     28 S SDWLINS="" F  S SDWLINS=$O(^TMP("SDWLRSR1",$J,SDWLINS)) Q:SDWLINS=""  D  Q:POP  D T2  Q:POP  W !,"________________" I $Y>(IOSL-8) D:$D(SDWLSPT) SCR Q:POP  D HD,HD1  ;SD*5.3*412 added Quit for early exit; 446
     29 .I $$S^%ZTLOAD S DUOUT="" Q
     30 .W !!,"INSTITUTION: ",SDWLINS,!
     31 .S SDWLTY="" F  S SDWLTY=$O(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY)) Q:SDWLTY=""  D  Q:POP  ;SD*5.3*412 added Quit for early exit
     32 ..S SDWLTNM=$$EXTERNAL^DILFD(409.3,4,,SDWLTY) W !,$E(SDWLTNM,1,15)
     33 ..S SDWLSCN="" F  S SDWLSCN=$O(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN)) Q:SDWLSCN=""  D  Q:POP  ;SD*5.3*412 added Quit for early exit
     34 ...S SDWLSCNM="" F  S SDWLSCNM=$O(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM)) Q:SDWLSCNM=""  D  Q:POP  D T1  Q:POP  ;SD*5.3*412 added Quit
     35 ....S SDWLPRI="" F  S SDWLPRI=$O(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI)) Q:SDWLPRI=""  D  Q:POP  ;SD*5.3*412 added Quit
     36 .....N SDWLCLO  ; SD*5.3*446
     37 .....W !,?2,$E(SDWLSCNM,1,10)," ",$S(SDWLPRI="A":"ASAP",SDWLPRI="F":"FUTURE",1:"")
     38 .....S SDWLPR=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"PR")) W ?20,SDWLPR
     39 .....S SDWLCLO=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"CL")) W ?27,SDWLCLO  ;SD*5.3*446
     40 .....S SDWLD=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLD")) W ?34,SDWLD  ;SD*5.3*415,446
     41 .....S SDWLNC=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLNC")) W ?41,SDWLNC  ;SD*5.3*415,446
     42 .....S SDWLSA=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLSA")) W ?48,SDWLSA  ;SD*5.3*415,446
     43 .....S SDWLCC=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLCC")) W ?55,SDWLCC  ;SD*5.3*415,446
     44 .....S SDWLNN=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLNN")) W ?62,SDWLNN  ;SD*5.3*415,446
     45 .....S SDWLER=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLER")) W ?69,SDWLER  ;SD*5.3*415,446
     46 .....S SDWLCL=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLCL")) W ?76,SDWLCL  ;SD*5.3*415,446
     47 .....S SDWLTR=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLTR")) W ?83,SDWLTR  ;SD*5.3*415,446
     48 .....S SDWLAD=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"AD")) W ?90,SDWLAD  ;SD*5.3*415,446
     49 .....S SDWLRR=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"RR")) W ?97,SDWLRR  ;SD*5.3*415,446
     50 .....S SDWLNR=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"NR")) W ?104,SDWLNR  ;SD*5.3*446
     51 .....S T1=T1+SDWLPR,TT1=TT1+SDWLPR
     52 .....S T2=T2+SDWLCLO,TT2=TT2+SDWLCLO  ;SD*5.3*446
     53 .....S T3=T3+SDWLD,TT3=TT3+SDWLD
     54 .....S T4=T4+SDWLNC,TT4=TT4+SDWLNC
     55 .....S T5=T5+SDWLSA,TT5=TT5+SDWLSA
     56 .....S T6=T6+SDWLCC,TT6=TT6+SDWLCC
     57 .....S T7=T7+SDWLNN,TT7=TT7+SDWLNN
     58 .....S T8=T8+SDWLER,TT8=TT8+SDWLER
     59 .....S T9=T9+SDWLCL,TT9=TT9+SDWLCL  ;SD*5.3*446
     60 .....S T10=T10+SDWLTR,TT10=TT10+SDWLTR  ;SD*5.3*446
     61 .....S T11=T11+SDWLAD,TT11=TT11+SDWLAD  ;SD*5.3*446
     62 .....S T12=T12+SDWLRR,TT12=TT12+SDWLRR  ;SD*5.3*446
     63 .....S T13=T13+SDWLNR,TT13=TT13+SDWLNR  ;SD*5.3*446
     64 .....I $Y>(IOSL-8) D:$D(SDWLSPT) SCR Q:POP  D HD,HD1  ;SD*5.3*412,446
     65 Q
     66SCR S DIR(0)="E" D ^DIR S:X="^" POP=1  ;SD*5.3*412
     67 Q
     68T1 ;
     69 ;write sub-totals
     70 W !?20,"------ ------ ------ ------ ------ ------ ------ ------ ------ ------ ------ ------ ------"  ;SD*5.3*446
     71 W !,"Sub-Totals:",?20,T1,?27,T2,?34,T3,?41,T4,?48,T5,?55,T6,?62,T7,?69,T8,?76,T9,?83,T10,?90,T11,?97,T12,?104,T13  ;SD*5.3*446
     72 S (T1,T2,T3,T4,T5,T6,T7,T8,T9,T10,T11,T12,T13)=0  ;SD*5.3*415,446
     73 I $Y>(IOSL-8) D:$D(SDWLSPT) SCR Q:POP  D HD,HD1  ;SD*5.3*412,446
     74 Q
     75T2 W !,"Institution Totals:"
     76 W ?20,TT1,?27,TT2,?34,TT3,?41,TT4,?48,TT5,?55,TT6,?62,TT7,?69,TT8,?76,TT9,?83,TT10,?90,TT11,?97,TT12,?104,TT13,!  ;SD*5.3*446
     77 S (TT1,TT2,TT3,TT4,TT5,TT6,TT7,TT8,TT9,TT10,TT11,TT12,TT13)=0  ;SD*5.3*415,446
     78 I $Y>(IOSL-8) D:$D(SDWLSPT) SCR Q:POP  D HD,HD1  ;SD*5.3*412,446
     79 Q
     80HD W:$D(IOF) @IOF S SDWLPG=SDWLPG+1 W !!,SDWLDTP,?80-$L("Wait List (Sch/PCMM) Stat Report")\2,"Wait List (Sch/PCMM) Stat Report",?65,"Page: ",SDWLPG
     81 W !,?80-$L("STARTED Date: ")\2,"STARTED Date: " S Y=$P(SDWLDATE,U,1) D DD^%DT W Y
     82 W !,?80-$L("FINISHED Date: ")\2,"FINISHED Date: " S Y=$P(SDWLDATE,U,2) D DD^%DT W Y
     83 Q
     84HD1 ;
     85 W !,?20,"PREV",?90,"#",?97,"#",?104,"# NOT"  ;SD*5.3*415,446
     86 W !,"WAIT LIST TYPE",?20,"REMN",?27,"CLSD",?34,"DTH",?41,"NC",?48,"SA",?55,"CC",?62,"NN",?69,"ER",?76,"CL",?83,"TR",?90,"ADD",?97,"REMN",?104,"REMVD"  ;SD*5.3*446
     87 Q
     88END D EN^SDWLKIL
     89 K ^TMP("SDWLRSR1",$J),^TMP("SDWLRSR2",$J),SDWLY1,SDWLX1,SDWLRDT,CT,I
     90 K T1,T2,T3,T4,T5,T6,T7,T8,T9,T10,T11,T12,T13,SDWLAD,SDWLBD,SDWLCC,SDWLCT,SDWLDFDT,SDWLDP,SDWLED,SDWLER,SDWLERR,SDWLFLD,X1,X2,DATE  ;SD*5.3*415,446
     91 K TT1,TT2,TT3,TT4,TT5,TT6,TT7,TT8,TT9,TT10,TT11,TT12,TT13,SDWLINSN,SDWLINST,SDWLNC,SDWLNN,SDWLNR,SDWLOFDT,SDWLOK1,SDWLOK2,SDWLTYPN  ;SD*5.3*415,446
     92 K SDWLOK3,SDWLPR,SDWLPR,SDWLPROM,SDWLRE,SDWLRFDT,SDWLRR,SDWLSA,SDWLSCN,SDWLSCNM,SDWLTASK,SDWLTK,SDWLTNM,SDWLTYNM,SDWLTYP,X4,SDWLTR,SDWLCL  ;SD*5.3*415,446
     93 Q
Note: See TracChangeset for help on using the changeset viewer.