Changeset 636 for FOIAVistA/tag/r/SCHEDULING-SD-SC
- Timestamp:
- Dec 4, 2009, 8:26:01 PM (14 years ago)
- Location:
- FOIAVistA/tag/r
- Files:
-
- 76 edited
- 1 copied
-
. (copied) (copied from FOIAVistA/trunk/r )
-
SCHEDULING-SD-SC/SCAPMC14.m (modified) (2 diffs)
-
SCHEDULING-SD-SC/SCAPMC29.m (modified) (3 diffs)
-
SCHEDULING-SD-SC/SCAPMC30.m (modified) (2 diffs)
-
SCHEDULING-SD-SC/SCAPMC9.m (modified) (2 diffs)
-
SCHEDULING-SD-SC/SCMCDD2.m (modified) (2 diffs)
-
SCHEDULING-SD-SC/SCMCHLB1.m (modified) (3 diffs)
-
SCHEDULING-SD-SC/SCMCHLB2.m (modified) (3 diffs)
-
SCHEDULING-SD-SC/SCMCHLS.m (modified) (2 diffs)
-
SCHEDULING-SD-SC/SCMCMU2.m (modified) (2 diffs)
-
SCHEDULING-SD-SC/SCMCPT2.m (modified) (2 diffs)
-
SCHEDULING-SD-SC/SCMCPT6.m (modified) (2 diffs)
-
SCHEDULING-SD-SC/SCMCQK1.m (modified) (2 diffs)
-
SCHEDULING-SD-SC/SCMCTSK1.m (modified) (14 diffs)
-
SCHEDULING-SD-SC/SCMCTSK2.m (modified) (7 diffs)
-
SCHEDULING-SD-SC/SCMCTSK3.m (modified) (3 diffs)
-
SCHEDULING-SD-SC/SCMCTSK4.m (modified) (3 diffs)
-
SCHEDULING-SD-SC/SCMCTSK9.m (modified) (2 diffs)
-
SCHEDULING-SD-SC/SCMCYPC.m (modified) (1 diff)
-
SCHEDULING-SD-SC/SCMSVUT2.m (modified) (2 diffs)
-
SCHEDULING-SD-SC/SCRPBK11.m (modified) (2 diffs)
-
SCHEDULING-SD-SC/SCRPEC.m (modified) (3 diffs)
-
SCHEDULING-SD-SC/SCRPEC2.m (modified) (3 diffs)
-
SCHEDULING-SD-SC/SCRPITP.m (modified) (3 diffs)
-
SCHEDULING-SD-SC/SCRPITP2.m (modified) (4 diffs)
-
SCHEDULING-SD-SC/SCRPPAT2.m (modified) (7 diffs)
-
SCHEDULING-SD-SC/SCRPPAT3.m (modified) (3 diffs)
-
SCHEDULING-SD-SC/SCRPRAC2.m (modified) (5 diffs)
-
SCHEDULING-SD-SC/SCRPSLT.m (modified) (3 diffs)
-
SCHEDULING-SD-SC/SCRPSLT2.m (modified) (4 diffs)
-
SCHEDULING-SD-SC/SCRPTA.m (modified) (2 diffs)
-
SCHEDULING-SD-SC/SCRPTA2.m (modified) (4 diffs)
-
SCHEDULING-SD-SC/SCRPTM.m (modified) (3 diffs)
-
SCHEDULING-SD-SC/SCRPTM2.m (modified) (4 diffs)
-
SCHEDULING-SD-SC/SCRPTP.m (modified) (5 diffs)
-
SCHEDULING-SD-SC/SCRPTP2.m (modified) (4 diffs)
-
SCHEDULING-SD-SC/SCRPTP3.m (modified) (5 diffs)
-
SCHEDULING-SD-SC/SCRPU1.m (modified) (2 diffs)
-
SCHEDULING-SD-SC/SCRPU2.m (modified) (4 diffs)
-
SCHEDULING-SD-SC/SCRPW24.m (modified) (2 diffs)
-
SCHEDULING-SD-SC/SCRPW6.m (modified) (2 diffs)
-
SCHEDULING-SD-SC/SCRPW8.m (modified) (6 diffs)
-
SCHEDULING-SD-SC/SCRPW9.m (modified) (4 diffs)
-
SCHEDULING-SD-SC/SDAMBAE2.m (modified) (1 diff)
-
SCHEDULING-SD-SC/SDAMBAE3.m (modified) (1 diff)
-
SCHEDULING-SD-SC/SDAMODO3.m (modified) (2 diffs)
-
SCHEDULING-SD-SC/SDBT.m (modified) (2 diffs)
-
SCHEDULING-SD-SC/SDBT1.m (modified) (1 diff)
-
SCHEDULING-SD-SC/SDBT10.m (modified) (1 diff)
-
SCHEDULING-SD-SC/SDBT11.m (modified) (1 diff)
-
SCHEDULING-SD-SC/SDBT2.m (modified) (1 diff)
-
SCHEDULING-SD-SC/SDBT3.m (modified) (1 diff)
-
SCHEDULING-SD-SC/SDBT4.m (modified) (1 diff)
-
SCHEDULING-SD-SC/SDBT5.m (modified) (2 diffs)
-
SCHEDULING-SD-SC/SDBT6.m (modified) (1 diff)
-
SCHEDULING-SD-SC/SDBT7.m (modified) (1 diff)
-
SCHEDULING-SD-SC/SDBT8.m (modified) (1 diff)
-
SCHEDULING-SD-SC/SDBT9.m (modified) (1 diff)
-
SCHEDULING-SD-SC/SDC.m (modified) (2 diffs)
-
SCHEDULING-SD-SC/SDCLAS.m (modified) (2 diffs)
-
SCHEDULING-SD-SC/SDCLAV0.m (modified) (1 diff)
-
SCHEDULING-SD-SC/SDCWL2.m (modified) (2 diffs)
-
SCHEDULING-SD-SC/SDD0.m (modified) (2 diffs)
-
SCHEDULING-SD-SC/SDLT.m (modified) (2 diffs)
-
SCHEDULING-SD-SC/SDN1.m (modified) (2 diffs)
-
SCHEDULING-SD-SC/SDNOS0.m (modified) (2 diffs)
-
SCHEDULING-SD-SC/SDPFSS.m (modified) (2 diffs)
-
SCHEDULING-SD-SC/SDWLE.m (modified) (1 diff)
-
SCHEDULING-SD-SC/SDWLI.m (modified) (6 diffs)
-
SCHEDULING-SD-SC/SDWLQSR.m (modified) (4 diffs)
-
SCHEDULING-SD-SC/SDWLRP4.m (modified) (2 diffs)
-
SCHEDULING-SD-SC/SDWLRSR.m (modified) (4 diffs)
-
SCHEDULING-SD-SC/SDXA.m (modified) (4 diffs)
-
SCHEDULING-SD-SC/SDXA1.m (modified) (10 diffs)
-
SCHEDULING-SD-SC/SDXACSE.m (modified) (4 diffs)
-
SCHEDULING-SD-SC/SDXACSE1.m (modified) (10 diffs)
-
SCHEDULING-SD-SC/SDXACSE2.m (modified) (4 diffs)
Legend:
- Unmodified
- Added
- Removed
-
FOIAVistA/tag/r/SCHEDULING-SD-SC/SCAPMC14.m
r628 r636 1 1 SCAPMC14 ;ALB/REW - Team API's: PTPR ; JUN 30, 1995 2 ;;5.3;Scheduling;**41 ,520**;AUG 13, 1993;Build 262 ;;5.3;Scheduling;**41**;AUG 13, 1993 3 3 ;;1.0 4 4 PTPR(SC200,SCDATES,SCPURPA,SCROLEA,SCLIST,SCERR,SCYESCL) ; -- list patients for a pract (scyescl NOT supported) … … 67 67 .Q:'SCOK 68 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) 69 .S SC44=$P($G(^SCTM(404.57,+SCTP,0)),U,9) 70 .Q:'SC44 71 .S SCOK=$$PTCL^SCAPMC(SC44,"SCDTPR",.SCLIST,.SCERR) 75 72 PRACQ Q $G(@SCERR@(0))<1 76 73 ; -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SCAPMC29.m
r628 r636 1 1 SCAPMC29 ;ALB/REW - TEAM APIs:CLPT ; 2/17/00 1:33pm 2 ;;5.3;Scheduling;**41,210 ,520**;AUG 13, 1993;Build 262 ;;5.3;Scheduling;**41,210**;AUG 13, 1993 3 3 ;;1.0 4 4 CLPT(DFN,SCDATES,SCTEAMA,SCLIST,SCERR) ;clinics for patient … … 48 48 .F SCX=1:1 S SCTP=+$G(SCPOSAX(SCX)) Q:'SCTP S SCPOSA(SCTP)="" 49 49 .S:$D(@SCTEAMA@("EXCLUDE")) SCPOSA("EXCLUDE")="" 50 ;S SCX=0 F S SCX=$O(^DPT(DFN,"DE",SCX)) Q:'SCX D51 ;.S SC44=+$G(^DPT(DFN,"DE",SCX,0))52 ;.Q:'SC4453 ;.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 D56 ;..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)+163 ;..;bp/ar nois brx-1298-12323 prevent undefined variable error64 ;..;New code begins65 ;..Q:'SCACT66 ;..Q:'SCN67 ;.;End of brx-1298-1232368 ;..S @SCLIST@(0)=SCN69 ;..S @SCLIST@(SCN)=SC44_U_SCCLNM_U_SCACT_U_SCINACT_U_SCACOPT_U_SCREVDT70 ;..S @SCLIST@("SCCL",SC44,SCACT,SCN)=""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 71 PTCLQ Q $G(@SCERR@(0))<1 72 72 ; … … 75 75 IF '$D(SCPOSA) S SCOK=1 G QTOKC 76 76 S (SCOK,SCTP)=0 77 F S SCTP=$O(^SCTM(404.57," E",+SC44,SCTP)) Q:'SCTP S:$$OKARRAY^SCAPU1(.SCPOSA,SCTP) SCOK=177 F S SCTP=$O(^SCTM(404.57,"D",+SC44,SCTP)) Q:'SCTP S:$$OKARRAY^SCAPU1(.SCPOSA,SCTP) SCOK=1 78 78 QTOKC Q SCOK 79 79 ; -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SCAPMC30.m
r628 r636 1 1 SCAPMC30 ;ALB/REW - TEAM APIs:TPCL ; 30 Jun 95 2 ;;5.3;Scheduling;**41 ,520**;AUG 13, 1993;Build 262 ;;5.3;Scheduling;**41**;AUG 13, 1993 3 3 ;;1.0 4 4 TPCL(SC44,SCDATES,SCPOSA,SCUSRA,SCPURPA,SCROLEA,SCLIST,SCERR) ; -- list of positions for a clinic … … 58 58 S SCOK=1 59 59 G:'$$OKDATA CLTPQ 60 S SCTP=0 F S SCTP=$O(^SCTM(404.57," E",SC44,SCTP)) Q:'SCTP D Q:'SCOK60 S SCTP=0 F S SCTP=$O(^SCTM(404.57,"D",SC44,SCTP)) Q:'SCTP D Q:'SCOK 61 61 .S SCTP0=$G(^SCTM(404.57,SCTP,0)) 62 62 .IF '$L(SCTP0) D -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SCAPMC9.m
r628 r636 1 1 SCAPMC9 ;ALB/REW - Team API's:PRCL ; JUN 26, 1995 2 ;;5.3;Scheduling;**41,112 ,520**;AUG 13, 1993;Build 262 ;;5.3;Scheduling;**41,112**;AUG 13, 1993 3 3 ;;1.0 4 4 PRCL(SC44,SCDATES,SCPOSA,SCUSRA,SCROLEA,SCLIST,SCERR) ;-- list of practitioners for clinic … … 54 54 ; -- loop through team positions 55 55 S SCTP=0 56 F S SCTP=$O(^SCTM(404.57," E",SC44,SCTP)) Q:SCTP="" D56 F S SCTP=$O(^SCTM(404.57,"D",SC44,SCTP)) Q:SCTP="" D 57 57 .Q:'$$OKARRAY^SCAPU1(.SCPOSA,SCTP) 58 58 .S SCND=$G(^SCTM(404.57,SCTP,0)) -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCDD2.m
r628 r636 1 1 SCMCDD2 ;ALB/REW - DD Calls used by PCMM ; 27 March 1996 2 ;;5.3;Scheduling;**41,107 ,520**;AUG 13, 1993;Build 262 ;;5.3;Scheduling;**41,107**;AUG 13, 1993 3 3 ;1 4 4 USEPCDEF(SCCL) ;how should pc practitioner be used for clinic … … 24 24 S SCOK=0 25 25 S SCXTP=0 26 F S SCXTP=$O(^SCTM(404.57," E",SCCL,SCXTP)) Q:('SCXTP)!(SCXTP=SCTP) D26 F S SCXTP=$O(^SCTM(404.57,"D",SCCL,SCXTP)) Q:('SCXTP)!(SCXTP=SCTP) D 27 27 .I $P(^SCTM(404.57,SCXTP,0),U,2)'=SCTM Q 28 28 .S SCOK=1 -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCHLB1.m
r628 r636 1 SCMCHLB1 ;BP OI/DJB - PCMM HL7 Bld Segment Array Cont.;8/17/992 ;;5.3;Scheduling;**177,515 ,524**;08/17/99;Build 291 SCMCHLB1 ;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 3 ; 4 4 SEGMENTS(DFN,SUB) ;Build EVN & PID segments … … 46 46 ; Array of ZPC segments 47 47 ; 48 NEW DATA,DATE,ID,ID1,LINETAG, SUB,TYPE,VAFZPC48 NEW DATA,DATE,ID,ID1,LINETAG,NUM,TYPE,VAFZPC 49 49 ; 50 S SUB=051 F S SUB=$O(ARRAY(SUB)) Q:'SUBD ;50 S NUM=0 51 F S NUM=$O(ARRAY(NUM)) Q:'NUM D ; 52 52 . S TYPE="" 53 . F S TYPE=$O(ARRAY( SUB,TYPE)) Q:TYPE="" D ;53 . F S TYPE=$O(ARRAY(NUM,TYPE)) Q:TYPE="" D ; 54 54 .. S ID="" 55 .. F S ID=$O(ARRAY( SUB,TYPE,ID)) Q:ID="" D ;56 ... S DATA=$G(ARRAY( SUB,TYPE,ID))55 .. F S ID=$O(ARRAY(NUM,TYPE,ID)) Q:ID="" D ; 56 ... S DATA=$G(ARRAY(NUM,TYPE,ID)) 57 57 ... I $G(DELETE) S DATA="^^^" ;A Delete type ZPC segment 58 58 ... E D ;....................A ZPC segment with data … … 74 74 ....S DATA=DATA_"^"_ROLE 75 75 ... ; 76 ... D BLDZPC^SCMCHLS ;..Build segment ; og/sd/524 77 ... D CPYZPC^SCMCHLS ;..Copy segment into array ; og/sd/524 76 ... S LINETAG="BLDZPC" 77 ... D @LINETAG^SCMCHLS ;..Build segment 78 ... S LINETAG="CPYZPC" 79 ... D @LINETAG^SCMCHLS ;..Copy segment into array 78 80 Q 79 81 ; -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCHLB2.m
r628 r636 1 SCMCHLB2 ;BP OI/DJB - PCMM HL7 Bld Segment Array Deletes;3/6/002 ;;5.3;Scheduling;**177,204,210,224 ,524**;08/13/93;Build 291 SCMCHLB2 ;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 3 ; 4 4 PTP ;Entry has been deleted from file 404.43. Send deletes to NPCD. … … 20 20 S ID=PTPI_"-" 21 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 22 . S DATA="^^^" ;........A Delete type ZPC segment 24 23 . ;djb/bp Patch 210. Eliminate indirection[rel 204] 25 24 . D BLDZPC^SCMCHLS ;..Build segment (needs ID & DATA) … … 65 64 .. S ID="" 66 65 .. 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 66 ... S DATA="^^^" ;........A Delete type ZPC segment 69 67 ... ;djb/bp Patch 210. Eliminate indirection[rel 204] 70 68 ... D BLDZPC^SCMCHLS ;..Build segment (needs ID & DATA) -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCHLS.m
r628 r636 1 SCMCHLS ;BP OI/DJB - PCMM HL7 Segment Utils;12/13/992 ;;5.3;Scheduling;**177,210,212,293,515 ,524**;08/13/93;Build 291 SCMCHLS ;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 3 ; 4 4 ;Ref rtn: SCDXMSG1 … … 37 37 ; PATCH 515 DLL USE ORIG TRIG 38 38 ; old code = M @XMITARRY@($P(ID,"-",1),"ZPC",ID)=VAFZPC 39 M @XMITARRY@( SUB,"ZPC",ID)=VAFZPC ; og/sd/52439 M @XMITARRY@(NUM,"ZPC",ID)=VAFZPC 40 40 Q 41 41 ; -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCMU2.m
r628 r636 1 SCMCMU2 ;ALB OI/MJK - PCMM Mass Team/Position Unassignment Processing;07/10/982 ;;5.3;Scheduling;**148,177 ,524**;AUG 13, 1993;Build 291 SCMCMU2 ;ALB/MJK - PCMM Mass Team/Position Unassignment Processing ; 10-JUL-1998 2 ;;5.3;Scheduling;**148,177**;AUG 13, 1993 3 3 ; 4 4 QUE() ; -- queue mass unassignment … … 169 169 . ; -- if assignment date is in future then delete 170 170 . IF SCASDT>DT,SCASDT>SCDATE D Q 171 . . N DA,DI E,DIK,DR172 . . S DA=SCIEN, (DIE,DIK)="^SCPT(404.43,",DR=".04///"_DT D ^DIE ; og/sd/524171 . . N DA,DIK 172 . . S DA=SCIEN,DIK="^SCPT(404.43," 173 173 . . D LOCK(SCNODE) 174 174 . . D ^DIK -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCPT2.m
r628 r636 1 SCMCPT2 ; GENERATED FROM 'SCMC INCONSISTENT' PRINT TEMPLATE (#14 48) ; 12/27/06 ; (FILE 404.57, MARGIN=132)1 SCMCPT2 ; GENERATED FROM 'SCMC INCONSISTENT' PRINT TEMPLATE (#1467) ; 12/25/06 ; (FILE 404.57, MARGIN=132) 2 2 G BEGIN 3 3 N W ! … … 12 12 BEGIN ; 13 13 S:'$D(DN) DN=1 S DISTP=$G(DISTP),DILCT=$G(DILCT) 14 I $D(DXS)<9 M DXS=^DIPT(14 48,"DXS")14 I $D(DXS)<9 M DXS=^DIPT(1467,"DXS") 15 15 S I(0)="^SCTM(404.57,",J(0)=404.57 16 16 W ?0 S X=$P($$GETPRTP^SCAPMCU2(D0,DT),U,2) W $E(X,1,8) K Y(404.57,304) -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCPT6.m
r628 r636 1 SCMCPT6 ; GENERATED FROM 'SCMC DIRECT PC FTEE 1 CLN' PRINT TEMPLATE (#14 52) ; 12/27/06 ; (FILE 404.52, MARGIN=132)1 SCMCPT6 ; GENERATED FROM 'SCMC DIRECT PC FTEE 1 CLN' PRINT TEMPLATE (#1471) ; 12/25/06 ; (FILE 404.52, MARGIN=132) 2 2 G BEGIN 3 3 CP G CP^DIO2 … … 21 21 BEGIN ; 22 22 S:'$D(DN) DN=1 S DISTP=$G(DISTP),DILCT=$G(DILCT) 23 I $D(DXS)<9 M DXS=^DIPT(14 52,"DXS")23 I $D(DXS)<9 M DXS=^DIPT(1471,"DXS") 24 24 S I(0)="^SCTM(404.52,",J(0)=404.52 25 25 S X=$G(^SCTM(404.52,D0,0)) W ?0 S Y=$P(X,U,3) S Y=$S(Y="":Y,$D(^VA(200,Y,0))#2:$P(^(0),U),1:Y) W $E(Y,1,15) -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCQK1.m
r628 r636 1 SCMCQK1 ;ALB OI/REW - Single Pt Tm/Pt Tm Pos Assign and Discharge;11/07/022 ;;5.3;Scheduling;**148,177,231,264,436,297,446 ,524**;AUG 13, 1993;Build 291 SCMCQK1 ;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 3 ; 4 4 ;04/25/2006 SD*5.3*446 INTER-FACILITY TRANSFER … … 11 11 G:SCDISCH<1 QTUNTP 12 12 G:'$$CONFIRM() QTUNTP 13 S OK= $$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER) ; og/sd/52413 S OK=1 ;$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER) 14 14 G:OK'>0 QTUNTP 15 15 S SCCL=$P($G(^SCTM(404.57,+$G(SCTP),0)),U,9) -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCTSK1.m
r628 r636 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:262 ;;5.3;Scheduling;**297,498,527 ,499**;AUG 13, 1993;Build 213 Q 4 INACTIVE ; 5 ; Flag patients6 N I,CNT,SC297,TPZ,TYDT,TEAMN,STDT,Q,SDDT,STDD S CNT=07 D DT^DICRW8 N SD1 S SDDT="" F SD1=DT,DT-1 I $D(^XTMP("SCMCTSK2-"_SD1,$J,"START")) S SDDT=SD1 Q9 I SDDT'>0 D DT^DICRW S SDDT=DT10 S %DT="",X="T-11M" D ^%DT S STDD=+Y1 SCMCTSK1 ;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 4 INACTIVE ;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 11 S A="^SCPT(404.43,""ADFN""",L="""""" 12 12 S Q=A_")" … … 14 14 .S ENTRY=+$P(Q,",",6) 15 15 .S ZERO=$G(^SCPT(404.43,+ENTRY,0)) 16 .I $P(ZERO,U,15) Q17 16 .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 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 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 24 30 .S DFN=$P(Q,",",3) 25 31 .I $G(XPDIDTOT),('(DFN#5)) D UPDATE^XPDID(DFN) 26 32 .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 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 40 SEEN ;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 49 48 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) 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)="" 53 51 F I=TYDT:0 S I=$O(^SCE("ADFN",DFN,I)) Q:'I D Q:SEEN 54 . S J=0 FS J=$O(^SCE("ADFN",DFN,I,J)) Q:'J D Q:SEEN52 .F J=0:0 S J=$O(^SCE("ADFN",DFN,I,J)) Q:'J D Q:SEEN 55 53 ..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 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 58 DIS ;discharge 67 59 N ZERO S ZERO=$G(^SCPT(404.43,+ENTRY,0)) 68 I $P(ZERO,U,4) Q 60 I $P(ZERO,U,4) Q ;Already discharged 69 61 D DIS2^SCMCTSK7 70 62 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 63 EXTEND(DATA,SCTEAM) ;return list of patients to inactivate in next 60 days 75 64 ;IEN^POSITION^PATIENT^EXTENDED^REASON 76 65 K DATA,SCDATA,SDDATA 77 66 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 67 D DT^DICRW S X="T-9M" D ^%DT S STDT=Y 82 68 S X="T-21M" D ^%DT S TYDT=+Y ;MAKE THIS 21 83 69 S POSA="" … … 91 77 .S CNT=CNT+1 92 78 Q 93 POS I '$$DATES^SCAPMCU1(404.59,POS) Q ;Position inact79 POS I '$$DATES^SCAPMCU1(404.59,POS) Q ;Not an active position 94 80 I '$P($G(^SCTM(404.57,POS,0)),U,4) Q ;Not PC 95 ; patients forposition81 ;get patients for this position 96 82 K ^TMP("SC TMP LIST",$J) 97 83 S X=$$PTTP^SCAPMC(POS,"",.SCLIST,.SCERR) … … 101 87 .I '$P($G(^SCPT(404.43,+$P(SCDATA,U,3),0)),U,15) Q 102 88 .S DFN=+SCDATA 103 .D SEEN (DFN,POS,TYDT,SDDT,.PROV,.PRECP,.SEEN)Q:SEEN89 .D SEEN Q:SEEN 104 90 .S SDDATA($P($G(^SCTM(404.57,POS,0)),U),$P(SCDATA,U,2),+SCDATA)=SCDATA,CNT=CNT+1 105 91 K @SCLIST … … 107 93 FILE(RES,DATA) ;File data on FTEE 108 94 N I 109 F I=1:1 Q:'$D(DATA(I)) D95 F I=1:1 Q:'$D(DATA(I)) D 110 96 .S $P(DATA(I),U,7)=$TR($P(DATA(I),U,7),"[]") 111 97 .S ZERO=$G(^SCPT(404.43,+DATA(I),0)) … … 116 102 I $O(FLDA(0)) D FILE^DIE("E","FLDA","ERR") 117 103 Q 118 SCREEN ; Active assign. screen104 SCREEN ;Screen for active assignments 119 105 N A S A=$G(^SCTM(404.52,D0,0)) 120 106 N J S J=-(DT+1),J=$O(^SCTM(404.52,"AIDT",+A,1,J)) I J="" S X=0 Q … … 124 110 I '$D(^SCTM(404.52,"AIDT",+A,1,J,D0)) S X=0 Q 125 111 S X=1 Q 126 SUM(PR,POSI) ; get pos for prov112 SUM(PR,POSI) ; get positions for this provider 127 113 N I,INS,ZERO,SCA,TEAM,FTEE,Z 128 114 S I="",FTEE=0 … … 139 125 .S FTEE=FTEE+$P(ZERO,U,9) 140 126 Q FTEE 141 FTEECHK(DATA,PAIEN) ;check Ftee >1127 FTEECHK(DATA,PAIEN) ;check Ftee greater than 1 142 128 N A S A=$G(^SCTM(404.52,+PAIEN,0)),FTEE=$$SUM(+$P(PAIEN,U,3),+A) 143 129 S DATA=0 144 130 S DATA=FTEE+$P(PAIEN,U,2) 145 131 Q 146 SORT (DIPA,SDD) ;sort tmpl147 N DIC 132 SORT ;sort template 133 N DIC,DIPA 148 134 S DIC=4,DIC(0)="ZME" 149 135 S DIC("S")="I $D(^SCTM(404.51,""AINST"",+Y))" 150 136 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 Q152 D ^DIC I Y<0 S DIPA("SI")=X S SDD=X Q:SDD[U D137 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 153 139 .S DIR("A")="Go to Institutiton",DIR("B")="LAST" S DIR(0)="F" D ^DIR 154 140 .I X="LAST" S DIPA("EI")="zzz" … … 156 142 D ^DIC 157 143 I Y>0 S DIPA("EI")=$P(Y(0),U) 158 I Y<0 S DIPA("EI")=X S SDD=X Q:SDD[U159 S SDD=1 Q144 I Y<0 S DIPA("EI")=X Q:X[U 145 S X=1 Q 160 146 FTEERPT ;FTEE REPORT 161 147 D FTERPT^SCMCTSK6 Q … … 169 155 S DATA=0 170 156 I ('INFO)!('$P(INFO,U,2)) Q 171 ; Is provider role acceptable?157 ;Check if provider can be in this role. 172 158 S J=-(DT+1) S J=$O(^SCTM(404.52,"AIDT",+INFO,1,J)) Q:J="" 173 159 I $O(^SCTM(404.52,"AIDT",+INFO,0,-(DT+1)))<J Q … … 191 177 S SCDFN=+Y W !,SCDFN 192 178 SCDFN S SC1="^SCPT(404.43,""APCPOS"",SCDFN,1)" 193 ;quit if no PC assign 179 ; 180 ;quit if no PC assignments 194 181 Q:'$D(@SC1) 195 182 S SCADT=0 196 183 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) 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) 211 201 Q 212 202 PRSEED ;seed practitioner … … 214 204 S SC177=$$PDAT^SCMCGU("SD*5.3*177") 215 205 I +SC177=0 D Q 216 . S SC2=" NoSD*5.3*177 Installation Date."206 . S SC2=" Unable to obtain SD*5.3*177 Installation Date." 217 207 . D MSG^SCMCCV6(SC1,SC2) 208 . Q 218 209 S DIC=200,DIC(0)="MEQA",DIC("A")="Select Provider: " D ^DIC Q:Y'>0 219 210 S SCPROV=+Y … … 230 221 . D ADD^SCMCHLE("NOW",SCVAR,,AH,1) 231 222 Q 232 INCON ; inconsistent PCassignments223 INCON ;get list of incositent provider assignments 233 224 N POS 234 225 D INCON^SCMCTSK3 … … 240 231 D EN1^DIP 241 232 Q 233 CHKENR(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 242 240 INACTDT(PA) ;Scheduled inactivation date. 243 241 D INACT^SCMCTSK3 Q -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCTSK2.m
r628 r636 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 1 SCMCTSK2 ;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 4 NIGHT ;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 14 11 S SIXM=$P($G(^SCTM(404.44,1,1)),U,9) 15 12 I SIXM D PRFLAG 16 13 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 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 19 18 .F ENTRY=0:0 S ENTRY=$O(^SCPT(404.43,"AFLG",DATE,ENTRY)) Q:'ENTRY D 20 19 ..S ZERO=$G(^SCPT(404.43,ENTRY,0)) Q:'ZERO 21 20 ..S DFN=+$G(^SCPT(404.42,+ZERO,0)) Q:'DFN 22 21 ..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 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 49 45 .D PRINAC 50 46 .N FLDA 51 47 .S FLDA(404.44,"1,",19)="" 52 48 .D FILE^DIE("I","FLDA","ERR") 53 D BULL K ^TMP($J,"SCMCTSK2")54 Q 55 UNFLG ; Unflagging49 D BULL 50 Q 51 UNFLG ;Remove the flag 56 52 N DR,DIE,DA 57 53 S DR=".15///@;.13///@;.12///@",DIE="^SCPT(404.43,",DA=ENTRY D ^DIE 58 54 Q 59 PRFLAG ;flag incorrect provider pos 55 PRFLAG ;flag incorrect provider positions 60 56 N POS 61 ;prov inact.has run once57 ;provider inactivation has run once 62 58 I $P($G(^SCTM(404.44,1,1)),U,11)'="" Q 63 59 D PRFLAG^SCMCTSK3 64 60 Q 65 PRINAC ;inact .flagged providers61 PRINAC ;inactivate flagged providers 66 62 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 63 ;Provider inactivation run already 64 S II=$P($G(^SCTM(404.44,1,1)),U,11) I II'="",II'=DT Q 70 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 71 66 .;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 ; inactivated73 .;Check valid criteria67 .I $O(^SCTM(404.52,"AIDT",+ZERO,0,-9999999))<(-$P(ZERO,U,2)) Q ;already inactivated 68 .;Check if criteria still valid 74 69 .S POS=+ZERO 75 .S PROV=+$$GETPRTP^SCAPMCU2(POS, SDDT)70 .S PROV=+$$GETPRTP^SCAPMCU2(POS,DT) 76 71 .S PC=$$GET^XUA4A72(+PROV) 77 72 .S DR=".091///@",DIE="^SCTM(404.52,",DA=I D ^DIE ;remove flag 78 73 .S ZERO1=$G(^SCTM(404.57,POS,0)) 79 74 .I '$D(^SD(403.46,+$P(ZERO1,U,3),2,+PC)) D 80 ..; inactivation81 ..S DIC="^SCTM(404.52,",X=+ZERO,DIC("DR")=".02////"_ SDDT_";.03////"_$P(ZERO,U,3)_";.04////0;.05///EMPLOYEE LEAVES POSITION;.11////1"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" 82 77 ..S DIC(0)="LM" D ^DIC 83 ;only run inact. once84 S $P(^SCTM(404.44,1,1),U,11)= SDDT85 Q 86 FUTAPP(DFN) ;print future app ts78 ;only run the inactivation once. 79 S $P(^SCTM(404.44,1,1),U,11)=DT 80 Q 81 FUTAPP(DFN) ;print future appointments 87 82 N TAB,SCDT0 S TAB=$X 88 I $G(SDDT)="" S SDDT=DT 89 S SCDT=SDDT+.24 83 S SCDT=DT+.24 90 84 F S SCDT=$O(^DPT(DFN,"S",SCDT)) Q:'SCDT D 91 85 . S SCDT0=$G(^DPT(DFN,"S",SCDT,0)) Q:$L($P(SCDT0,U,2)) … … 93 87 . S Y=SCDT X ^DD("DD") W $E(Y_" ",1,17)_" "_$E($P($G(^SC(+CLIEN,0)),U),1,10) 94 88 Q 95 GETASC(DATA,ENTRY) ;get assoc .clinics89 GETASC(DATA,ENTRY) ;get associated clinics 96 90 N I,CNT S CNT=0 97 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) 98 92 Q 99 SETASC(RESULT,DATA) ;set assoc .clinics93 SETASC(RESULT,DATA) ;set associated clinics 100 94 D SETASC^SCMCTSK7(.RESULT,DATA) Q 101 MSG(SCTP,DFN) ;send inact .message102 ;givenvalid positions get current practitioners95 MSG(SCTP,DFN) ;send inactivation message 96 ;given list of valid positions get current practitioners 103 97 S SCLIST="SCL" 104 I $G(SDDT)="" S SDDT=DT105 98 I "N"'[$P($G(^SCTM(404.57,SCTP,2)),U,9) D 106 99 .S SCOK=$$PRTP^SCAPMC(SCTP,"",.SCLIST,.SCERR) 107 100 .;if preceptor notice turned on for message type 108 101 I +$P($G(^SCTM(404.57,SCTP,2)),U,9) D 109 .S SCX=+$$OKPREC2^SCMCLK(SCTP, SDDT)102 .S SCX=+$$OKPREC2^SCMCLK(SCTP,DT) 110 103 .;if preceptor duz returned, add to array 111 104 .I SCX S @SCLIST@("SCPR",SCX)="" 112 105 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 PCteam position "_$P($G(^SCTM(404.57,SCTP,0)),U)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) 114 107 S XMSUB="Provider's Inactivated Primary Care Patients" D ^XMD 115 108 Q 116 BULL ; EOMBulletin109 BULL ;end of Month Bulletin 117 110 N DISUPNO,BY,DHIT,HEAD 118 111 S DISUPNO=1,L=0 119 S XMSUB="Patients Scheduled for Inactivation from P CPanel"112 S XMSUB="Patients Scheduled for Inactivation from Primary Care Panel" 120 113 S XMY("G.PCMM PATIENT/PROVIDER INACTIVE")="" 121 114 K ^TMP("SCMC",$J),^TMP("SCMCTXT",$J),^TMP("SCML",$J) … … 130 123 .K XMY S XMY(SCI)="" K ^TMP("SCMC",$J),^TMP("SCMCTXT",$J) 131 124 .M ^TMP("SCMC",$J)=^TMP("SCF",$J,SCI) 132 .S XMSUB="Patients Scheduled for Inactivation from P CPanel"125 .S XMSUB="Patients Scheduled for Inactivation from Primary Care Panel" 133 126 .S XMTEXT="^TMP(""SCMCTXT"",$J," 127 .;D LINES(1) D ^XMD 134 128 S DISUPNO=1 135 129 K ^TMP("SCMC",$J),^TMP("SCMCTXT") 136 I $G(NOINAC) K ^TMP($J,"SCMCTSK2") Q ; SD/499137 130 S XMSUB="Patients With Extended PCMM Inactivation Dates" 138 131 S XMY("G.PCMM PATIENT/PROVIDER INACTIVE")="" … … 147 140 S DISUPNO=1 148 141 K ^TMP("SCMC",$J),^TMP("SCMCTXT") 149 S XMSUB="Patients Automated Inactivations from P CPanels"142 S XMSUB="Patients Automated Inactivations from Primary Care Panels" 150 143 S XMY("G.PCMM PATIENT/PROVIDER INACTIVE")="" 151 144 K ^TMP("SCMC",$J) … … 160 153 K ^TMP("SCMC",$J),^TMP("SCMCTXT") 161 154 I $P($G(^SCTM(404.44,1,1)),U,11)="" D 162 . S XMSUB="P CProviders Scheduled for Inactivation"155 . S XMSUB="Primary Care Providers Scheduled for Inactivation" 163 156 . S XMY("G.PCMM PATIENT/PROVIDER INACTIVE")="" 164 157 . K ^TMP("SCMC",$J) … … 189 182 INRPT ; REPORT 190 183 N DIOEND,SCDHD 191 D PROMPT^SCMCTSK3("** Date Range Selection **","DATE PATIENTS INACTIVATED FROM PCPANELS")184 D PROMPT^SCMCTSK3("**** Date Range Selection ****","DATE PATIENTS INACTIVATED FROM PRIMARY CARE PANELS") 192 185 Q:'$D(^TMP("SC",$J,"XR")) 193 186 D UNASSIGN^SCMCTSK3 … … 201 194 D EN1^DIP 202 195 Q 203 IN30 ;inact .last month204 N DIPA,SDD D SORT^SCMCTSK1(.DIPA,.SDD) Q:'SDD ;SD/499196 IN30 ;inactivated last month 197 D SORT^SCMCTSK1 Q:'X 205 198 S Q="""" 206 199 S DIC="^SCPT(404.43,",L=0,BY="[SCMC INACTIVATION SORT]" -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCTSK3.m
r628 r636 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:472 ;;5.3;Scheduling;**297 ,499**;AUG 13, 1993;Build 211 SCMCTSK3 ;ALB/JDS - PCMM Inactivation Reports ; 7/19/05 10:06am 2 ;;5.3;Scheduling;**297**;AUG 13, 1993 3 3 Q 4 4 SORTP ;sort template … … 78 78 .D SUBT^SCRPW50(DATESORT) 79 79 .S SCBDT("B")="T-30",SCEDT("B")="TODAY" 80 .I (DATESORT["Scheduled Ina")!(DATESORT["Scheduled for Inactivation") S SCEDT("B")="T+ 60"80 .I (DATESORT["Scheduled Ina")!(DATESORT["Scheduled for Inactivation") S SCEDT("B")="T+30" 81 81 S LIST="DIV,TEAM,POS,ASPR" 82 82 ;D SUBT^SCRPW50("**** Date Range Selection ****") … … 210 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 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)) 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)) 215 214 .I '$P(ZERO,U,4) S FLDA(404.52,POSH_",",.091)="" Q 216 .;SD/499; added verification of the POSSIBLE PRIMARY PRACTITIONER field217 .;in the TEAM POSITION file218 .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)="" Q220 215 .I (-$O(^SCTM(404.52,"AIDT",+ZERO,0,-9999999)))>$P(ZERO,U,2) S FLDA(404.52,POSH_",",.091)="" 221 216 I $O(FLDA(0)) D FILE^DIE("I","FLDA","ERR") -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCTSK4.m
r628 r636 1 1 SCMCTSK4 ;ALB/JDS - PCMM Inactivation Reports ; 18 Apr 2003 9:36 AM 2 ;;5.3;Scheduling;**297 ,526**;AUG 13, 1993;Build 82 ;;5.3;Scheduling;**297**;AUG 13, 1993 3 3 Q 4 4 POSCHK ; … … 30 30 W !," Field Name Explanation of field name" 31 31 W !," Patient Name Name of patient scheduled to be inactivated from their primary care team and position/provider" 32 W !," SSN Patient SSN."32 W !," SSN Patient's last 4 Social Security numbers." 33 33 W !," PC Team Patient's assigned Primary Care team in PCMM." 34 34 W !," Provider Name of primary care practitioner/provider currently assigned to the patient. This will be an" … … 56 56 W !," Field Name Explanation of field name" 57 57 W !," Patient Name Name of patient scheduled to be inactivated from their primary care team and position/provider." 58 W !," SSN Patient SSN."58 W !," SSN Patient's last 4 SSN numbers." 59 59 W !," Institution Institution name, previously called Division, in which patient receives primary care." 60 60 W !," PC Team Patient's assigned Primary Care team in PCMM." -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCTSK9.m
r628 r636 1 1 SCMCTSK9 ;;BP/DMR - PCMM ; 18 Apr 2003 9:36 AM 2 ;;5.3;Scheduling;**297 ,526**;AUG 13, 1993;Build 82 ;;5.3;Scheduling;**297**;AUG 13, 1993 3 3 Q 4 4 EXTKEY ; … … 10 10 W ! 11 11 W !,"Patient Name Name of patient scheduled to be inactivated from their primary care team and position/provider." 12 W !,"SSN SSN number."12 W !,"SSN Patient's last 4 SSN numbers." 13 13 W !,"Institution Institution name, previously called Division, in which patient receives primary care." 14 14 W !,"PC Team The patient's assigned Primary Care team in PCMM." -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCYPC.m
r628 r636 1 SCMCYPC ; GENERATED FROM 'SCMC DIRECT PC FTEE' PRINT TEMPLATE (#1320) ; 12/2 7/06 ; (FILE 404.52, MARGIN=132)1 SCMCYPC ; GENERATED FROM 'SCMC DIRECT PC FTEE' PRINT TEMPLATE (#1320) ; 12/25/06 ; (FILE 404.52, MARGIN=132) 2 2 G BEGIN 3 3 CP G CP^DIO2 -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMSVUT2.m
r628 r636 1 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 12 ;;5.3;Scheduling;**66,180,254,293,325,466**;AUG 13,1993;Build 2 3 3 ;06/28/99 ACS Added CPT modifier validation 4 4 ; … … 195 195 I STDT="" Q 0 196 196 S STDT=$$FMDATE^HLFNC(STDT) 197 S X=STDT ,%DT="X" D ^%DT I Y=-1 Q 0 ;SD/521 added %DT197 S X=STDT D ^%DT I Y=-1 Q 0 198 198 I ENDT="" Q 1 199 199 S ENDT=$$FMDATE^HLFNC(ENDT) 200 S X=ENDT ,%DT="X" D ^%DT I Y=-1 Q 0 ;SD/521 added %DT200 S X=ENDT D ^%DT I Y=-1 Q 0 201 201 I $$FMDIFF^XLFDT(ENDT,STDT,1)<0 Q 0 202 202 Q 1 -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPBK11.m
r628 r636 1 1 SCRPBK11 ;MJK/ALB - RPC Broker Utilities ; 27 FEB 96 2 ;;5.3;Scheduling;**41 ,520**;AUG 13, 1993;Build 262 ;;5.3;Scheduling;**41**;AUG 13, 1993 3 3 ; 4 4 GETSEL(SCDATA,SCTYPE,SCIEN) ; … … 83 83 D SET(" Division: "_$S($G(SC(SCFLE,SCIEN,3.5))]"":SC(SCFLE,SCIEN,3.5),1:SCDEF),.SCINC,.SCDATA) 84 84 D SET(" ",.SCINC,.SCDATA) 85 D SET("Asso ciated Teams and Positions:",.SCINC,.SCDATA)85 D SET("Assoicated Teams and Positions:",.SCINC,.SCDATA) 86 86 D SET("-------------------------------",.SCINC,.SCDATA) 87 S SCI=0 F S SCI=$O(^SCTM(404.57," E",SCID,SCI)) Q:'SCI D87 S SCI=0 F S SCI=$O(^SCTM(404.57,"D",SCID,SCI)) Q:'SCI D 88 88 . S X=$G(^SCTM(404.57,SCI,0)) 89 89 . D SET(" Team: "_$P($G(^SCTM(404.51,+$P(X,U,2),0)),U),.SCINC,.SCDATA) -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPEC.m
r628 r636 1 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 262 ;;5.3;Scheduling;**41,140,174,177,431**;AUG 13, 1993 3 3 ; 4 4 ;Detailed Listing of Patients and Their Enrolled Clinics Report … … 80 80 Q 81 81 ; 82 PDATA(DFN,CLNEN, CNAME,FLAG) ;82 PDATA(DFN,CLNEN,FLAG) ; 83 83 ;Collect and format data for report 84 84 ; 85 N NODE,NAME,PID,PELIG,MT,PSTAT,STATD,DATA,LAST,NEXT 85 N NODE,NAME,PID,PELIG,MT,PSTAT,STATD,DATA,LAST,NEXT,CEN,CNAME 86 86 S DATA="" 87 87 S NODE=$G(^DPT(DFN,0)) … … 90 90 S MT=$$LST^DGMTU(DFN),MT=$P(MT,"^",4) ;means test status SD*5.3*431 91 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 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 99 103 Q DATA 100 104 ; -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPEC2.m
r628 r636 1 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 82 ;;5.3;Scheduling;**41,140,174,177**;AUG 13, 1993 3 3 ; 4 4 ;Detailed Listing of Patients and Their Enrolled Clinics Report … … 106 106 S HLD="H1" 107 107 S @STORE@("SUBHEADER",HLD)="Patient Name" 108 S $E(@STORE@("SUBHEADER",HLD),1 6)="Pt ID"108 S $E(@STORE@("SUBHEADER",HLD),18)="Pt ID" 109 109 S $E(@STORE@("SUBHEADER",HLD),25)="Stat" 110 110 S $E(@STORE@("SUBHEADER",HLD),31)="Elig" … … 129 129 ;CIEN - clinic ien 130 130 ; 131 S @STORE@(INS,TIEN,CIEN,PTIEN)=$E($P(PDATA,"^"),1,1 2) ;patient name132 S $E(@STORE@(INS,TIEN,CIEN,PTIEN),1 4)=$P(PDATA,"^",2) ;primary long id 9 digit133 S $E(@STORE@(INS,TIEN,CIEN,PTIEN),2 6)=$P(PDATA,"^",3) ;means test category131 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 134 S $E(@STORE@(INS,TIEN,CIEN,PTIEN),31)=$P(PDATA,"^",4) ;primary eligibility 135 135 ;Removed by patch 174 -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPITP.m
r628 r636 1 1 SCRPITP ;ALB/CMM - Individual Team Profile ; 29 Jun 99 04:11PM 2 ;;5.3;Scheduling;**41,52,177 ,520**;AUG 13, 1993;Build 262 ;;5.3;Scheduling;**41,52,177**;AUG 13, 1993 3 3 ; 4 4 ;Individual Team Profile … … 105 105 ; 106 106 PRINTIT(STORE,TITL) ; 107 N INST,EINST,ETEAM,TEM,NEW,PAGE,TNAME,TIEN,EN,SUB,POS,CIEN,INF ,ACL107 N INST,EINST,ETEAM,TEM,NEW,PAGE,TNAME,TIEN,EN,SUB,POS,CIEN,INF 108 108 S (INST,EINST)="",STOP=0,(PAGE,NEW)=1 W:$E(IOST)="C" @IOF 109 109 D FORHEAD^SCRPITP2 … … 136 136 ..I $Y<IOSL-10 D COLUMN^SCRPITP2 137 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 138 141 ...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 ! 142 ..W ! 148 143 I 'STOP,$E(IOST)="C" N DIR S DIR(0)="E" W ! D ^DIR 149 144 Q -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPITP2.m
r628 r636 1 1 SCRPITP2 ;ALB/CMM - Individual Team Profile Continued ;7/25/99 18:24 2 ;;5.3;Scheduling;**41,177 ,520**;AUG 13, 1993;Build 262 ;;5.3;Scheduling;**41,177**;AUG 13, 1993 3 3 ; 4 4 ;Individual Team Profile … … 16 16 S POS=$P(TNODE,"^") ;position name 17 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 position18 S PPC=$S($P(TNODE,"^",4)'=1:"NPC",+$$OKPREC3^SCMCLK(TPOS,DT)>1:" AP",1:"PCP") ;primary care position 19 19 S MAX=$P(TNODE,"^",8) 20 20 ; … … 24 24 S SCPTASS=$$PCPOSCNT^SCAPMCU1(TPOS,DT,0) 25 25 ; 26 ;D FORMAT(POS,PPC,MAX,DIV,TM,TPOS,ROL,SCPROV,SCPTASS) 26 S CIEN=+$P(TNODE,"^",9) ;clinic ien 27 S PCLIN="" 28 I CIEN>0 S PCLIN=$P($G(^SC(CIEN,0)),"^") ;associated clinic 27 29 ; 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 30 D FORMAT(POS,PPC,MAX,DIV,TM,TPOS,ROL,PCLIN,SCPROV,SCPTASS) 33 31 ; 34 D FORMAT(POS,PPC,MAX,DIV,TM,TPOS,ROL,CNAME,SCPROV,SCPTASS)35 N AC36 S AC=037 F S AC=$O(CNAME(AC)) Q:AC="" D FORMATAC(POS,DIV,TM,TPOS,CNAME(AC))38 K CNAME39 32 Q 40 33 ; … … 101 94 S $E(@STORE@(DIV,TM,"P",POS),82)=$J(MAX,6,0) ;number of patients allowed 102 95 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) 96 S $E(@STORE@(DIV,TM,"P",POS),103)=$E(CNAME,1,30) ;clinic name 108 97 Q 109 98 ; -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPPAT2.m
r628 r636 1 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 262 ;;5.3;Scheduling;**41,48,174,181,177,231,433,297**;AUG 13, 1993 3 3 ; 4 4 ;Listing of Practitioner's Patients … … 26 26 ;ARY - array of patients for selected practitioner 27 27 ;PRAC - practitioner ien 28 N NXT,PIEN,TPIEN,PNAME,TPIEN,NODE,PTP,TPI,TPN,CLIEN, PTA,PTAN,TIEN29 N PC,TNODE,TNAME,PINF,POSN,PRCP ,CNAME28 N NXT,PIEN,TPIEN,PNAME,TPIEN,NODE,PTP,TPI,TPN,CLIEN,CNAME,PTA,PTAN,TIEN 29 N PC,TNODE,TNAME,PINF,POSN,PRCP 30 30 S NXT=0 31 31 F S NXT=$O(@ARY@(NXT)) Q:NXT=""!(NXT'?.N) D … … 49 49 .I $G(ROLE)'=1,'$D(ROLE(+$P(TPN,U,3))) Q ;not a selected role 50 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 51 .S CLIEN=+$P(TPN,"^",9) ;associated clinic ien 53 52 .;commented next line off - clinic enrollment no longer needed SD*5.3*433 54 53 .;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 check54 .S CNAME=$P($G(^SC(CLIEN,0)),"^") ; SD*5.3*433 remove enroll check 56 55 .S PC=$S($P(PTP,"^",5)=0:0,1:1) ;primary care position 1or2-yes/0-no 57 56 .S PNAME=$P($G(^VA(200,+PRAC,0)),"^") ;practitioner name 58 57 .Q:PNAME="" 59 58 .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) 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 75 62 Q 76 63 ; 77 CECHK(CLIEN,CNAME,PIEN) ; should no longer be used as of patch SD*5.3*43364 CECHK(CLIEN,CNAME,PIEN) ; 78 65 ;CLIEN - clinic ien 79 66 ;CNAME - clinic name returned if patient is enrolled in clien clinic … … 112 99 Q 113 100 ; 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) ; 101 STOR(IIEN,SEC,TRD,PINF,PNAME,TNAME,TPI) ; 136 102 ;IIEN - ien institution 137 103 ;SEC - second sort subscript, IEN team or IEN practitioner … … 144 110 N PIEN,PTNAME,PID 145 111 S PIEN=+$P(PINF,"^") ;patient ien 146 S PTNAME=$E($P(PINF,"^",2),1,1 0) ;patient name112 S PTNAME=$E($P(PINF,"^",2),1,15) ;patient name 147 113 Q:$D(@STORE@("PT",IIEN,SEC,TRD,TPI,PTNAME,PIEN)) 148 114 S @STORE@("PT",IIEN,SEC,TRD,TPI,PTNAME,PIEN)="" 115 ; 149 116 I 'SUMM,'$D(@STORE@("PTOT",IIEN,SEC,TRD,PIEN)) D 150 117 .;count each unique patient for any given practitioner for grand total … … 157 124 S @STORE@(IIEN,SEC,TRD,TPI,PIEN)=PTNAME 158 125 S PID=$P(PINF,"^",3),PID=$TR(PID,"-","") 159 S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),1 3)=PID ;ssn126 S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),18)=$E(PID,6,10) ;last 4 pid - 5 places is for any pseudo 160 127 S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),25)=$P(PINF,"^",4) ;means test status 161 128 S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),31)=$P(PINF,"^",5) ;eligibility … … 166 133 S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),66)=$E(CNAME,1,15) ;clinic 167 134 Q 168 STORA(IIEN,SEC,TRD,PINF,PNAME,TNAME,TPI,SCCNT) ;169 I '$D(@STORE@(IIEN,SEC,TRD,TPI,PIEN,SCCNT)) D170 .S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN,SCCNT),42)=$P(PINF,"^",8) ;last appt171 .S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN,SCCNT),54)=$P(PINF,"^",9) ;nxt appt172 .S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN,SCCNT),66)=$E(CNAME,1,15) ;clinic173 .Q174 Q -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPPAT3.m
r628 r636 1 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 262 ;;5.3;Scheduling;**41,52,148,174,181,177,297**;AUG 13, 1993 3 3 ; 4 4 ;Listing of Practitioner's Patients … … 12 12 .S PT=0 13 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 14 17 ..I FIRST D HEADER S FIRST=0 15 18 ..W !,$G(@STORE@(INS,SEC,TRD,POS,PT)) ;print patient detail line 16 ..;I FIRST D HEADER S FIRST=017 ..N SCCN18 ..S SCCN=""19 ..F S SCCN=$O(@STORE@(INS,SEC,TRD,POS,PT,SCCN)) Q:SCCN="" D20 ...W !,$G(@STORE@(INS,SEC,TRD,POS,PT,SCCN)) ;print patient detail line21 ...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)) HEADER22 ...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 HEADER23 ...Q:STOP24 ...;I FIRST D HEADER S FIRST=025 ...Q26 19 ..Q 27 20 .Q … … 74 67 SHEAD ; 75 68 S @STORE@("H2")="Pt Name" 76 S $E(@STORE@("H2"),1 5)="Pt ID"69 S $E(@STORE@("H2"),18)="Pt ID" 77 70 S $E(@STORE@("H1"),25)="M.T." 78 71 S $E(@STORE@("H2"),25)="Stat" -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPRAC2.m
r628 r636 1 1 SCRPRAC2 ;ALB/CMM - Practitioner Demographics continued ; 29 Jun 99 04:11PM 2 ;;5.3;Scheduling;**41,177 ,520**;AUG 13, 1993;Build 262 ;;5.3;Scheduling;**41,177**;AUG 13, 1993 3 3 ; 4 4 ;Practitioner Demographics Report … … 40 40 .S MAX=$P(NODE,"^",8) ;max patient assignments to position 41 41 .S ASSIGN=+$$PCPOSCNT^SCAPMCU1(PIEN,DT,0) ;assigned patients 42 .N CNAME,SCCLIEN 43 .D SETASCL(PIEN,.CNAME,.SCCLIEN) ;associated clinics 42 .S CNAME=$P($G(^SC(+$P(NODE,U,9),0)),U) ;associated clinic 44 43 .; 45 44 .;Get preceptor … … 57 56 .D SET1("Phone",PHONE),SET2("Pts. Assigned",ASSIGN) 58 57 .I $L($G(PRCP)) D SET3(1,"Preceptor: "_PRCP) 59 .D SET3(4,"Assoc. Clinic:")60 .D SET CNAME(.CNAME)58 .D SET3(4,"Assoc.") 59 .D SET3(4,"Clinic: "_CNAME) 61 60 .I $L(PCLASS(1)) D 62 61 ..D SET3(4,"Person"),SET3(5,"Class: "_PCLASS(1)) D … … 83 82 Q 84 83 ; 85 SETASCL(PIEN,CNAME,SCCLIEN) ;SET ASSOCIATED CLINICS86 N I,CNT187 S CNT1=0,I=088 F S I=$O(^SCTM(404.57,PIEN,5,I)) Q:'I D89 .S SCCLIEN(CNT1)=I,CNAME(CNT1)=$P($G(^SC(I,0)),U),CNT1=CNT1+190 Q91 84 SET1(LABEL,VALUE) ;Set output line 92 85 S SCLN=SCLN+1 … … 109 102 Q 110 103 ; 111 SETCNAME(CNAME) ;associated clinics112 N A113 S A="" F S A=$O(CNAME(A)) Q:A="" D SET3(12,CNAME(A))114 Q115 ;116 104 PINFO(VAE,PRACT,OPH,ROOM,SERV) ; 117 ;practitioner information f rom new person file105 ;practitioner information form new person file 118 106 S PRACT=$P($G(^VA(200,VAE,0)),"^") ;practitioner name 119 107 S OPH=$P($G(^VA(200,VAE,.13)),"^",2) ;office phone -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPSLT.m
r628 r636 1 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 262 ;;5.3;Scheduling;**41,52,177,231**;AUG 13, 1993 3 3 ; 4 4 ;Summary Listing of Teams Report … … 105 105 ; 106 106 PRINTIT(STORE,TITL) ; 107 N INST,EINST,ETEAM,TEM,EPRACT,PRACT,NXT,PAGE,NPAGE,NEW,POS ,SCAC107 N INST,EINST,ETEAM,TEM,EPRACT,PRACT,NXT,PAGE,NPAGE,NEW,POS 108 108 S (INST,EINST)="",(NPAGE,STOP)=0,PAGE=1 W:$E(IOST)="C" @IOF 109 109 D TITLE^SCRPU3(.PAGE,TITL) … … 130 130 ...S POS="" 131 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 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 140 136 ..Q:STOP 141 137 ..I IOST'?1"C-".E,$Y>(IOSL-8) D NEWP^SCRPSLT2(INST,TEM,TITL,.PAGE,1) -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPSLT2.m
r628 r636 1 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 262 ;;5.3;Scheduling;**41,174,177,231**;AUG 13, 1993 3 3 ; 4 4 ;Summary Listing of Teams Report … … 23 23 S POS=$P(TNODE,"^") ;position name 24 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)) 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 29 27 S ROLN=$P($G(^SD(403.46,+ROL,0)),U) ;role name 30 28 ; … … 57 55 ; 58 56 D FORMAT(APOS,POS,PCLIN,VAE,PRACT,PPC,DIV,TM,NPC,MAX,PCN,XDAT) 59 N SCAC60 S SCAC=061 F S SCAC=$O(PCLIN(SCAC)) Q:SCAC="" D FORMATAC(APOS,POS,PCLIN(SCAC),VAE,DIV,TM)62 57 Q 63 58 ; … … 99 94 S $E(@STORE@(DIV,TM,VAE,APOS),128)=$J(TMP(2),5,0) ;precepted NPC 100 95 ;New code ends 101 Q102 FORMATAC(APOS,POS,PCLIN,VAE,DIV,TM) ;clinic multiples103 S $E(@STORE@(DIV,TM,VAE,APOS,SCAC),72)=$E(PCLIN,1,30)104 96 Q 105 97 ; -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPTA.m
r628 r636 1 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 82 ;;5.3;Scheduling;**41,48,52,114,174,181,177**;AUG 13, 1993 3 3 ; 4 4 ;Patient Listing w/Team Assignment Data Report … … 149 149 ;setup column headers 150 150 S @STORE@("H2")="Patient Name" 151 S $E(@STORE@("H2"), 19)="Pt ID"151 S $E(@STORE@("H2"),24)="Pt ID" 152 152 S $E(@STORE@("H1"),31)="Date" 153 153 S $E(@STORE@("H2"),31)="Assigned" -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPTA2.m
r628 r636 1 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 82 ;;5.3;Scheduling;**41,88,140,148,174,181,177**;AUG 13, 1993 3 3 ; 4 4 ;Patient Listing w/Team Assignment Data Report continued … … 70 70 S PTNAME=$P($G(^DPT(PIEN,0)),"^") ;patient name 71 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 72 S PID=$E(PID,6,10) ;last four pid include 5th for pseudo notation 74 73 ; 75 74 S ADATE=$P(NODE,"^",3) ;position assignment date - fm format … … 119 118 S $E(@STORE@(IIEN,TIEN),40)="Primary Care Team: "_$S(PC=1:"YES",1:"NO") 120 119 ; 121 S @STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN)=$E(PTNAME,1, 17)122 S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN), 19)=PID120 S @STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN)=$E(PTNAME,1,21) 121 S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),24)=PID 123 122 S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),31)=ADATE 124 123 S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),43)=PCAP … … 140 139 S PTNAME=$E($P($G(^DPT(PIEN,0)),"^"),1,20) ;patient name 141 140 S PID=$P($G(^DPT(PIEN,.36)),"^",3),PID=$TR(PID,"-","") 142 ;S PID=$E(PID,6,10) ;9 digit ssn patch 526141 S PID=$E(PID,6,10) ;last 4 plus 5th for psuedo 143 142 ; 144 143 S TIEN=+$P($G(^SCPT(404.42,PTIEN,0)),"^",3) ;team ien -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPTM.m
r628 r636 1 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 262 ;;5.3;Scheduling;**41,48,52,181,177**;AUG 13, 1993 3 3 ; 4 4 ;List of Team's Members Report … … 154 154 PRNTD(INST,TEM,PRACT,POS,TITL,PAGE,HEAD) ; 155 155 ; 156 N CNT ,SCAC156 N CNT 157 157 S CNT="" 158 158 I IOST'?1"C-".E,$Y>(IOSL-11) D NEWP^SCRPTM2(INST,TEM,TITL,.PAGE,.HEAD) … … 161 161 F S CNT=$O(@STORE@(INST,TEM,PRACT,POS,CNT)) Q:CNT=""!(STOP) D 162 162 .W !,$G(@STORE@(INST,TEM,PRACT,POS,CNT)) 163 .S SCAC="" I CNT=4 D164 ..F S SCAC=$O(@STORE@(INST,TEM,PRACT,POS,4,SCAC)) Q:SCAC=""!(STOP) D165 ...W !,$G(@STORE@(INST,TEM,PRACT,POS,4,SCAC))166 163 Q -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPTM2.m
r628 r636 1 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 262 ;;5.3;Scheduling;**41,140,177**;AUG 13, 1993 3 3 ; 4 4 ;List of Team's Members Report … … 31 31 .; 32 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 33 .S PCLIN=+$P(TPNODE,"^",9) ;associated clinic ien 34 .S PCLIN=$P($G(^SC(PCLIN,0)),"^") ;associated clinic name 37 35 .; 38 36 .;Get preceptor … … 53 51 .; 54 52 .D FORMAT(PNAME,TPIEN,PCLIN,RNAME,UNAME,ACT,INACT,PRIEN,PRNAME,OPH,ROOM,SERV,INS,TIEN,PRCP,.PCLASS) 55 .N SCAC56 .S SCAC=057 .F S SCAC=$O(PCLIN(SCAC)) Q:SCAC="" D FORMATAC(INS,TIEN,PRIEN,TPIEN,PCLIN(SCAC))58 53 Q 59 54 ; … … 110 105 Q 111 106 ; 112 FORMATAC(DIV,TEM,PIEN,TPIEN,PCLIN) ;113 S $E(@STORE@(DIV,TEM,PIEN,TPIEN,4,SCAC),49)=$E(PCLIN,1,30)114 Q115 ;116 107 NEWP(INST,TEM,TITL,PAGE,HEAD) ; 117 108 ;new page -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPTP.m
r628 r636 1 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 262 ;;5.3;Scheduling;**41,48,174,177**;AUG 13, 1993 3 3 ; 4 4 PROMPTS ;Prompt for Institution, Team, Role, Patient Status and Print device … … 20 20 ;ROLE - roles selected (variable and array) 21 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 ID22 ;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 23 N ZTSAVE,II 24 24 F II="INST","TEAM","ROLE","ROLE(","SORT","PSTAT","INST(","TEAM(" S ZTSAVE(II)="" … … 31 31 ;ROLE - roles selected (variable and array) 32 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 ID33 ;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 34 ;IOP - print device 35 35 ;ZTDTH - queue time (optional) … … 114 114 Q FOUND 115 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 116 FORMAT(INS,TIEN,PTIEN,PTNAME,PID,PIEN,PNAME,CNAME,LAST,NEXT,ROLN,PCAP) ;Format column information 149 117 ;INS - Institution ien 150 118 ;TIEN - team ien … … 170 138 I (SORT=1)!(SORT=2) S SEC=PTIEN,TRD=PIEN ;sort doesn't include practitioner 171 139 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 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 177 148 Q -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPTP2.m
r628 r636 1 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 262 ;;5.3;Scheduling;**41,53,52,174,177,231**;AUG 13, 1993 3 3 ; 4 4 ;List of Team's Patients Report … … 73 73 . . . . Q:STOP 74 74 . . . . I $D(@STORE@(INST,TIEN,PIEN,TRDI)) W !,$G(@STORE@(INST,TIEN,PIEN,TRDI)) ;write column data 75 . . . . N SCACL76 . . . . S SCACL="" F S SCACL=$O(@STORE@(INST,TIEN,PIEN,TRDI,SCACL)) Q:SCACL="" D77 . . . . . W !,$G(@STORE@(INST,TIEN,PIEN,TRDI,SCACL))78 75 . S NEW=0 79 76 Q … … 102 99 . . . . Q:STOP 103 100 . . . . I $D(@STORE@(INST,TIEN,TRDI,PIEN)) W !,$G(@STORE@(INST,TIEN,TRDI,PIEN)) ;write column data 104 . . . . N SCACL105 . . . . S SCACL="" F S SCACL=$O(@STORE@(INST,TIEN,TRDI,PIEN,SCACL)) Q:SCACL="" D106 . . . . . W !,$G(@STORE@(INST,TIEN,TRDI,PIEN,SCACL))107 101 . S NEW=0 108 102 Q … … 137 131 SETH ;sets column headings 138 132 S @STORE@("H2")="Patient Name" 139 S $E(@STORE@("H2"), 18)="Pt ID"133 S $E(@STORE@("H2"),25)="Pt ID" 140 134 S $E(@STORE@("H2"),32)="Practitioner" 141 135 S $E(@STORE@("H2"),56)="Role" -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPTP3.m
r628 r636 1 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 2 ;;5.3;Scheduling;**41,48,98,177,231,433**;AUG 13, 1993 4 3 ; 5 4 ;List of Team's Patients Report … … 25 24 .S DFN=PTIEN 26 25 .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) 26 .S PID=VA("BID") 29 27 .; 30 .N CNAME,PINF,CLIEN 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 31 49 .S CNT="" 32 50 .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) 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")="" 34 71 Q 35 72 ; 36 TPAR(PTAI,START,PINF,CNAME,CLIEN,PNAME,ROLN,PCAP) ; 37 N PTPA,TPIEN,TPNODE,ROL,CIEN,ENROLL,OKAY,NEXT,LAST,PAIEN 73 TPAR(PTAI,START) ; 74 N PTPA,TPIEN,TPNODE,ROL,CNAME,CIEN,ENROLL,OKAY,PNAME,NEXT,LAST,PAIEN 75 N ROLN,PCAP 38 76 I '$D(^SCPT(404.43,"B",PTAI)) Q "0^[Not Assigned]" 39 77 ; ^ no patient team position assignment … … 43 81 .S PTPA=START 44 82 I PTPA="" Q "0^[Not Assigned]" 45 S PTPAN=$G(^SCPT(404.43,PTPA,0)) ;patient team assignment83 S PTPAN=$G(^SCPT(404.43,PTPA,0)) ;patient team position assignment node 46 84 I PTPAN=""!(PTPAN=0) Q "0^[Not Assigned]" 47 85 I $P(PTPAN,"^",4)'="",$P(PTPAN,"^",4)<DT Q -1 … … 57 95 S PCAP=$S($P(PTPAN,U,5)<1:"NPC",+$$OKPREC3^SCMCLK(TPIEN,DT)>0:" AP",1:"PCP") ;PC? 58 96 ; 59 D SETASCL^SCRPRAC2(TPIEN,.CNAME,.CLIEN) 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 ; 60 105 ;next two lines commented off - SD*5.3*433 61 106 ;S ENROLL=$$ENRL(PTIEN,CIEN) ;enrolled in associated clinic … … 67 112 I +PAIEN=0 S PIEN=0,PNAME="[Inactive Position]" 68 113 ; 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 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 87 117 ; 88 ENRL(PTIEN,CLIEN) ;FUNCTIONALITY DISABLED 118 Q PIEN_U_PNAME_U_CNAME_U_LAST_U_NEXT_U_ROLN_U_PCAP 89 119 ; 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 120 ENRL(PTIEN,CLIEN) ; 121 ; 122 N FOUND,ENODE,EN,NXT 101 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 102 134 Q FOUND 103 135 ; -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPU1.m
r628 r636 1 1 SCRPU1 ;ALB/CMM - GENERIC PROMPTS FOR PCMM REPORTS ;1/12/96 2 ;;5.3;Scheduling;**41,45,130 ,520**;AUG 13, 1993;Build 262 ;;5.3;Scheduling;**41,45,130**;AUG 13, 1993 3 3 ; 4 4 INST ;Prompt for institution … … 109 109 N TRUE,EN,TEAM 110 110 S TRUE=0,EN="" 111 F S EN=$O(^SCTM(404.57," E",+Y,EN)) Q:EN=""!(TRUE) D111 F S EN=$O(^SCTM(404.57,"D",+Y,EN)) Q:EN=""!(TRUE) D 112 112 .S TEAM=+$P($G(^SCTM(404.57,EN,0)),"^",2) 113 113 .I $D(VAUTT(TEAM))!(VAUTT=1) S TRUE=1 -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPU2.m
r628 r636 1 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 262 ;;5.3;Scheduling;**41,174,297**;AUG 13, 1993 3 3 ; 4 4 DTRANG(FIRST,SECOND) ;Date Range - begin date ^ end date => fileman format … … 29 29 N TPEN,FOUND,TEAM 30 30 S TPEN="",FOUND=0 31 F S TPEN=$O(^SCTM(404.57," E",CLN,TPEN)) Q:TPEN=""!(FOUND) D31 F S TPEN=$O(^SCTM(404.57,"D",CLN,TPEN)) Q:TPEN=""!(FOUND) D 32 32 .S TEAM=$P(^SCTM(404.57,TPEN,0),"^",2) 33 33 .I $D(^SCPT(404.42,"APTTM",DFN,TEAM)) S FOUND=1 … … 122 122 SORT2() ;Prompt for sorting by: 123 123 ; [1] Division, Team, Patient Name 124 ;or [2] Division, Team, SSN124 ;or [2] Division, Team, Last 4 Pt ID 125 125 ;or [3] Division, Team, Practitioner, Patient Name 126 ;or [4] Division, Team, Practitioner, SSN126 ;or [4] Division, Team, Practitioner, Last 4 Pt ID 127 127 ; 128 128 EN4 ; 129 129 N X 130 130 W !,"Sort By:",!?10,"[1] Division, Team, Patient Name" 131 W !?10,"[2] Division, Team, SSN"131 W !?10,"[2] Division, Team, Last 4 Pt ID" 132 132 W !?10,"[3] Division, Team, Practitioner, Patient Name" 133 W !?10,"[4] Division, Team, Practitioner, SSN"133 W !?10,"[4] Division, Team, Practitioner, Last 4 Pt ID" 134 134 W !!,"Select 1, 2, 3, or 4: " 135 135 R X:DTIME … … 141 141 ;help prompt 142 142 W !,"Enter: ",!?5,"- 1 to sort by Division, Team, Patient Name" 143 W !?10,"- 2 to sort by Division, Team, SSN"143 W !?10,"- 2 to sort by Division, Team, Last 4 Pt ID" 144 144 W !?10,"- 3 to sort by Division, Team, Practitioner, Patient Name" 145 W !?10,"- 4 to sort by Division, Team, Practitioner, SSN"145 W !?10,"- 4 to sort by Division, Team, Practitioner, Last 4 Pt ID" 146 146 Q -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPW24.m
r628 r636 1 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;Build32 ;;5.3;Scheduling;**144,163,180,254,243,295,329,351**;AUG 13, 1993 3 3 ;06/19/99 ACS - Added CPT modifier API calls 4 4 ; … … 189 189 ; 190 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 entered191 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 192 S SDI=$O(SDY(SDATE),-1) Q:'SDI "" S X1=$P($P(SDOE0,U),"."),X2=SDI D ^%DTC Q SDY(SDI) 193 193 ; -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPW6.m
r628 r636 1 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 32 ;;5.3;Scheduling;**139,144,466**;AUG 13, 1993;Build 2 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 4 D SUBT^SCRPW50("**** Status Selection ****") … … 7 7 S SDSTA=$S(Y=1:2,Y=2:8,1:"2^8") 8 8 QUE W !!,"This report requires 132 column output.",! 9 N ZTSAVE F X="SDDIV","SDDIV(","SDDNU(", "SDSTA"S ZTSAVE(X)=""9 N ZTSAVE F X="SDDIV","SDDIV(","SDDNU(",SDSTA S ZTSAVE(X)="" 10 10 D EN^XUTMDEVQ("UNIQ^SCRPW6","Trend Facility Uniques",.ZTSAVE),DISP0^SCRPW23 Q 11 11 UNIQ ;Calculate/print uniques -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPW8.m
r628 r636 1 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 32 ;;5.3;Scheduling;**139,145,144,176,339,466**;AUG 13, 1993;Build 2 3 3 QS ;Queue outpatient encounter workload report 4 4 D PARM^SCRPW9 Q … … 28 28 PRPT ;Print statistics page 29 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))30 S SDCT=0 F SDI=1,2,3,11,14,8 S SDCT=SDCT+$G(^TMP(SDS1,$J,SDS2,SDI)) 31 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 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 IAP34 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:SDOUT33 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 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 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) … … 52 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 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 ,SDNCOUD END^SCRPW50 Q54 K I,SDFF,SDOUT,SDSTOP D END^SCRPW50 Q 55 55 ; 56 56 HD1() ;Report subheader 1 … … 83 83 ; 84 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)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 86 Q 87 87 ; 88 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 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) Q90 IAP 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 91 91 STOP ;Check for stop task request 92 92 S:$G(ZTQUEUED) (SDOUT,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q 93 93 ; 94 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 95 S SDSTOP=SDSTOP+1 I SDSTOP#3000=0 D STOP Q:SDOUT 97 96 D C1("SCRPW",SDDNAM) D:SDMD C1("SCRPWD",SDDIV) D:SDCLGR C1("SCRPWC",SDCG) Q … … 99 98 C1(SDS1,SDS2) ;Set ^TMP global 100 99 ;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 100 S DFN=$P(SDOE0,U,2),SDSTAT=+$P(SDOE0,U,12) I SDZ(0),SDZ(4)=SDDIV,SDS1="SCRPW" D DETAIL 105 101 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 Q102 Q:SDSTAT=4 D:"114238"[SDSTAT VIS Q 107 103 ; 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 104 VIS S ^TMP(SDS1,$J,SDS2,"VISIT",$S(SDSTAT=2:"OWK",SDSTAT=8:"OWK",1:"NWK"),DFN,$P(SDDT,"."))="" Q:(SDSTAT'=2)&(SDSTAT'=8) 111 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 112 106 Q:$P(SDSTX,U)'=8 S ^TMP(SDS1,$J,SDS2,"VISIT","ACC",DFN,$P(SDDT,"."))="" … … 129 123 ; 130 124 DETAIL ;Set global for detailed list 131 N SDIF S SDIF=0132 125 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)="" Q134 I SDZ(1)="V", +SDSTAT'=4,'SDNCOU S:"114238"[+SDSTAT ^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,SDSSN,$P(SDDT,"."))="" Q126 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 135 128 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 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 142 131 D:+$$STX(SDOE,SDOE0)=SDZ(3) DSET Q 143 132 ; -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPW9.m
r628 r636 1 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 32 ;;5.3;Scheduling;**139,144,339,466**;AUG 13, 1993;Build 2 3 3 UNARL(SDS1,SDS2) ;Print list of 'action required'/not accepted uniques 4 4 ;Required input: SDS1,SDS2=subscript values … … 34 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 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 36 W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDZ(0)=-1 Q ;SD*5.3*339 add sub-zero 38 37 S SDZ(3)=+Y … … 47 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) 48 47 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)48 I "28"[$G(SDZ(2)) S SDH(4)="Transmission status: "_$P($T(TXS+SDZ(3)),";",2) 50 49 D DHDR Q:SDOUT I '$D(^TMP(SDS1,$J,SDS2,"DETAIL")) W !,"No records found in this category." Q 51 50 S SDCT=0 D @SDZ(1) Q … … 90 89 ;Transmitted, error 91 90 ;Transmitted, accepted 92 ;Non-Count (not transmitted)93 91 ; 94 92 PARM ;Prompt for report parameters -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SDAMBAE2.m
r628 r636 1 1 SDAMBAE2 ;ALB/BOK - ADD/EDIT CON'T ;11/21/91 12:15 ; 2 ;;5.3;Scheduling;**15,79,111,132**;Aug 13, 1993 2 ;;5.3;Scheduling;**15,79,111,132**;Aug 13, 1993;Build 1 3 3 ; 4 4 APP ; -- screen on APPOINTMENT TYPE field in VISIT file CLINIC STOP multiple -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SDAMBAE3.m
r628 r636 1 1 SDAMBAE3 ;ALB/BOK/MJK - ADD/EDIT CON'T ;7/8/91 12:18 ; 2 ;;5.3;Scheduling;**18,29,40,111,132**;Aug 13, 1993 2 ;;5.3;Scheduling;**18,29,40,111,132**;Aug 13, 1993;Build 1 3 3 ; 4 4 DUP ; -- inp transform to check for duplicate CPTs in ^DD(409.51,21:25,0) -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SDAMODO3.m
r628 r636 1 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;Build32 ;;5.3;Scheduling;**11,25,46,49,159**;Aug 13, 1993 3 3 Q 4 4 REPORT ; … … 96 96 N Y S Y=1 97 97 I PDIAG=1 G SELDXQ 98 S DIC="^ICD9(",DIC(0)=" XMS",X=DX_" " ;SD/52998 S DIC="^ICD9(",DIC(0)="MZ",X=DX 99 99 D ^DIC K DIC I Y<0 S Y=0 G SELDXQ 100 100 I $D(PDIAG($P(Y,U))) G SELDXQ -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SDBT.m
r628 r636 1 SDBT ; GENERATED FROM 'SDB' INPUT TEMPLATE(#485), FILE 44; 05/05/061 SDBT ; GENERATED FROM 'SDB' INPUT TEMPLATE(#485), FILE 44;10/02/06 2 2 D DE G BEGIN 3 3 DE S DIE="^SC(",DIC=DIE,DP=44,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^SC(DA,""))="" … … 148 148 C12 G C12S:$D(DE(12))[0 K DB 149 149 C12S S X="" G:DG(DQ)=X C12F1 K DB 150 C12F1 N X,X1,X2 S DIXR=4 58D C12X1(U) K X2 M X2=X D C12X1("O") K X1 M X1=X150 C12F1 N X,X1,X2 S DIXR=473 D C12X1(U) K X2 M X2=X D C12X1("O") K X1 M X1=X 151 151 I $G(X(1))]"" D 152 152 . K ^SC("AST",X,DA) -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SDBT1.m
r628 r636 1 SDBT1 ; ; 05/05/061 SDBT1 ; ;10/02/06 2 2 S X=DE(19),DIC=DIE 3 3 K ^SC("ALTP",$E(X,1,30),DA) -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SDBT10.m
r628 r636 1 SDBT10 ; ; 05/05/061 SDBT10 ; ;10/02/06 2 2 D DE G BEGIN 3 3 DE S DIE="^SC(",DIC=DIE,DP=44,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^SC(DA,""))="" -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SDBT11.m
r628 r636 1 SDBT11 ; ; 04/26/051 SDBT11 ; ;11/16/05 2 2 D DE G BEGIN 3 3 DE S DIE="^SC(",DIC=DIE,DP=44,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^SC(DA,""))="" -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SDBT2.m
r628 r636 1 SDBT2 ; ; 05/05/061 SDBT2 ; ;10/02/06 2 2 S X=DG(DQ),DIC=DIE 3 3 S ^SC("ALTP",$E(X,1,30),DA)="" -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SDBT3.m
r628 r636 1 SDBT3 ; ; 05/05/061 SDBT3 ; ;10/02/06 2 2 S X=DE(20),DIC=DIE 3 3 K ^SC("ALTC",$E(X,1,30),DA) -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SDBT4.m
r628 r636 1 SDBT4 ; ; 05/05/061 SDBT4 ; ;10/02/06 2 2 S X=DG(DQ),DIC=DIE 3 3 S ^SC("ALTC",$E(X,1,30),DA)="" -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SDBT5.m
r628 r636 1 SDBT5 ; ; 05/05/061 SDBT5 ; ;10/02/06 2 2 D DE G BEGIN 3 3 DE S DIE="^SC(",DIC=DIE,DP=44,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^SC(DA,""))="" … … 141 141 C16 G C16S:$D(DE(16))[0 K DB 142 142 C16S S X="" G:DG(DQ)=X C16F1 K DB 143 C16F1 N X,X1,X2 S DIXR=4 57D C16X1(U) K X2 M X2=X D C16X1("O") K X1 M X1=X143 C16F1 N X,X1,X2 S DIXR=472 D C16X1(U) K X2 M X2=X D C16X1("O") K X1 M X1=X 144 144 I $G(X(1))]"" D 145 145 . K ^SC("ACST",X,DA) -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SDBT6.m
r628 r636 1 SDBT6 ; ; 05/05/061 SDBT6 ; ;10/02/06 2 2 D DE G BEGIN 3 3 DE S DIE="^SC(D0,""PR"",",DIC=DIE,DP=44.1,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^SC(D0,"PR",DA,""))="" -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SDBT7.m
r628 r636 1 SDBT7 ; ; 05/05/061 SDBT7 ; ;10/02/06 2 2 D DE G BEGIN 3 3 DE S DIE="^SC(D0,""DX"",",DIC=DIE,DP=44.11,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^SC(D0,"DX",DA,""))="" -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SDBT8.m
r628 r636 1 SDBT8 ; ; 05/05/061 SDBT8 ; ;10/02/06 2 2 D DE G BEGIN 3 3 DE S DIE="^SC(D0,""SDPRIV"",",DIC=DIE,DP=44.04,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^SC(D0,"SDPRIV",DA,""))="" -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SDBT9.m
r628 r636 1 SDBT9 ; ; 05/05/061 SDBT9 ; ;10/02/06 2 2 D DE G BEGIN 3 3 DE S DIE="^SC(D0,""SI"",",DIC=DIE,DP=44.03,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^SC(D0,"SI",DA,""))="" -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SDC.m
r628 r636 1 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 62 ;;5.3;Scheduling;**15,32,79,132,167,478,487**;Aug 13, 1993 3 3 N SDATA,SDCNHDL ; for evt dvr 4 4 SDC1 K SDLT,SDCP S NOAP="" D LO^DGUTL … … 39 39 D S S ^(1)=" "_$E(SD,6,7)_" **CANCELLED**",FR=SD,TO=SD+.9 ;NAKED REFERENCE - ^SC(IFN,"ST",Date,1) 40 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 ,NODE41 N TDH,TMPD,DIE,DR 42 42 F I=0:0 S I=$O(^SC(SC,"S",FR,1,I)) Q:I'>0 D 43 43 .S DFN=+^SC(SC,"S",FR,1,I,0),SDCNHDL=$$HANDLE^SDAMEVT(1) 44 44 .D BEFORE^SDAMEVT(.SDATA,DFN,FR,SC,I,SDCNHDL) 45 45 .S $P(^SC(SC,"S",FR,1,I,0),"^",9)="C" 46 .S:$D(^DPT(DFN,"S",FR,0)) NODE=^(0) ;added SD/52347 .Q:$P(NODE,U,1)'=SC ;added SD/52348 46 .S ^DPT("ASDCN",SC,FR,DFN)="" 49 47 .S SDSC=SC,SDTTM=FR,SDPL=I,TDH=DH,TMPD=CANREM D CANCEL^SDCNSLT S DH=TDH ;SD/478 -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SDCLAS.m
r628 r636 1 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 62 ;;5.3;Scheduling;**63,243,517**;Aug 13, 1993;Build 4 3 3 ;SD/517 CORRECTED ALL $NEXT FUNCTIONAL COMMANDS 4 4 S DIV="" D DIV^SDUTL I $T D CALST^SDDIV Q:Y<0 … … 14 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 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'>0D PT16 ONE S ONE=1 D INIT S SDAPPT=0 F S SDAPPT=$O(^SC(SDIFN,"S",SDAPPT)) Q:'SDAPPT D PT 17 17 D:'SDFAST AEB^SDCLAS0 G ^SDCLAS1 18 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 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 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'>0D:'SDFAST AEB^SDCLAS0 Q21 APPT 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 22 Q 23 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 -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SDCLAV0.m
r628 r636 1 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 32 ;;5.3;Scheduling;**184,439,490,517**;Aug 13, 1993;Build 4 3 3 ;SD/517 CHANGED FOR LOOPS 4 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 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 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 7 S DGTCH="CLINIC AVAILABILITY REPORT^CLINIC^PAGE#" D:$E(IOST,1,2)="P-" TP^DGUTL K SDBD,SDCI,SDED D END^SDCLAV Q 10 8 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 9 S $P(^UTILITY($J,"SDNMS",D,SDNM),"^",3)=SDC -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SDCWL2.m
r628 r636 1 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;Build32 ;;5.3;Scheduling;**140,132,171,184**;Aug 13, 1993 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 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) … … 9 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 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*52911 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 12 K TIME I SDAS["C" S ^("CA")=^TMP($J,1,SDN,SDAPT,"CA")+1 Q 13 13 I SDAS="N"!(SDAS="NA") S ^("NS")=^TMP($J,1,SDN,SDAPT,"NS")+1 Q -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SDD0.m
r628 r636 1 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;Build32 ;;5.3;Scheduling;**167,401**;Aug 13, 1993 3 3 SETX ; 4 4 N SDDIV … … 8 8 S:SI=1 SI=4 S:SI=2 SI=4 S SDSOH=$S($P(SDSL,U,8)']"":0,1:1) 9 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*52910 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 11 Q 12 12 CHECK S X=DATE D DW^%DTC S DAY=$P("SUN^MON^TUES^WEDNES^THURS^FRI^SATUR",U,Y+1),DOW=Y -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SDLT.m
r628 r636 1 1 SDLT ;ALB/LDB - CANCELLATION LETTERS ; 14 Feb 2003 2 ;;5.3;Scheduling;**185,213,281,330,398 ,523**;Aug 13, 1993;Build 62 ;;5.3;Scheduling;**185,213,281,330,398**;Aug 13, 1993 3 3 ; 4 4 ;************************************************************************** … … 14 14 ; 15 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 16 PRT S Y=DT D DTS^SDUTL 19 17 I +$G(SDFIRST)=0 W @IOF ;SD*5.3*330 Form feed only after letter #1 20 18 K SDFIRST -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SDN1.m
r628 r636 1 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 62 ;;5.3;Scheduling;**330,340,398,455**;Aug 13, 1993 3 3 N SDBAD 4 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 … … 9 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 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 quit11 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 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 13 W:$D(^UTILITY($J,"NO")) !,"However, there are no letters assigned to the clinic(s).",!! -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SDNOS0.m
r628 r636 1 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 62 ;;5.3;Scheduling;**20,194,410,517**;Aug 13, 1993;Build 4 3 3 D END1^SDNOS 4 4 S (SDV1,SDIN,SDNM,SDNM1)=0,SDDIVO=SDDIV … … 33 33 Q 34 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 35 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) I $D(^DPT(SDPAT,"S",SDBEG1)) D CHK1 37 36 Q 38 37 ; -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SDPFSS.m
r628 r636 1 SDPFSS ;ALB/SCK - Patient Financial Services System ;22-APR-2005 2 ;;5.3;Scheduling;**430**;Aug 13, 1993 1 SDPFSS ;ALB/SCK - Patient Financial Services System ;11/24/0622-APR-2005 2 ;;5.3;Scheduling;**430,502**;Aug 13, 1993 ;Build 14 3 ; Modified from FOIA VISTA, 4 ; Copyright (C) 2007 WorldVistA 5 ; 6 ; This program is free software; you can redistribute it and/or modify 7 ; it under the terms of the GNU General Public License as published by 8 ; the Free Software Foundation; either version 2 of the License, or 9 ; (at your option) any later version. 10 ; 11 ; This program is distributed in the hope that it will be useful, 12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 ; GNU General Public License for more details. 15 ; 16 ; You should have received a copy of the GNU General Public License 17 ; along with this program; if not, write to the Free Software 18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 19 ; 3 20 ; 4 21 Q … … 11 28 ; Check conditions before proceeding 12 29 Q:'$G(DFN) 30 ; VWSD LOCAL MOD HERE SDVWNVAI VARIABLE, SEE DEFINITION AT VWSD LOCAL MOD BELOW 31 I $D(SDVWNVAI) G OVER 13 32 Q:'$$CHECK 33 OVER ; 34 ;END LOCAL MOD 14 35 Q:$$TESTPAT^VADPT(DFN) 15 ; 36 ;VWSD LOCAl MOD 16 37 ; Call the ICN API to generate an ICN if one does not exist for the patient. 38 ;VWSD SDVWNVAI VARIABLE -LOCAL MOD FOR disabling the need for ICN or use of other ICN system for non-VA system 17 39 S SDOK=$$ICNLC^MPIF001(DFN) 18 I SDOK<0 D 40 I $D(SDVWNVAI) G OVER1 41 I (SDOK<0) D 19 42 . D ERRMSG^SDPFSS2(SDOK) 20 43 ; 44 OVER1 ; 45 ;END LOCAL MOD 21 46 ; Get event type 22 47 S SDEVENT=$S($D(SDAMEVT):$$GET1^DIQ(409.66,SDAMEVT,.01),1:"OTHER") -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SDWLE.m
r628 r636 1 SDWLE ; BPOI/TEH - WAITING LIST-ENTER/EDIT;06/12/20022 ;;5.3;scheduling;**263,4 15,446,524**;08/13/93;Build 291 SDWLE ;;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 3 ; 4 4 ; -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SDWLI.m
r628 r636 1 SDWLI ; BPOI/TEH - DISPLAY PENDING APPOINTMENTS;6/1/052 ;;5.3;scheduling;**263,327,394,446 ,524**;08/13/93;Build 291 SDWLI ;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 3 ; 4 4 ; … … 30 30 ;PATIENT LOOK-UP FROM WAIT LIST PATIENT FILE (^SDWL(409.3,IEN,0). 31 31 ; 32 D SEL G EN:$D(DUOUT)33 32 D PAT Q:'$D(SDWLDFN) 34 33 G END:SDWLDFN<0,END:SDWLDFN="" 35 34 Q:$D(DUOUT) 36 35 EN1 K DIR,DIC,DR,DIE,SDWLDRG 36 D SEL G EN:$D(DUOUT) 37 37 D GETFILE 38 38 D DISP G EN:'$D(DUOUT) … … 40 40 Q 41 41 PAT ;PATIENT LOOK-UP 42 ;PATCH SD*5.3*524 - SET DIC("S") FOR SCREEN OF OPEN/CLOSED ENTRIES43 S DIC("S")="I $D(SDWLY),SDWLY,$P(^SDWL(409.3,+Y,0),U,17)=""O"""44 42 S DIC(0)="EMNQA",DIC=409.3 D ^DIC S (SDWLDFN,DFN)=$P(Y,U,2) 45 43 G PATEND:SDWLDFN="" … … 51 49 ;PROMPT FOR DISPLAY 'OPEN' WAITING LIST ONLY OR PROMPT FOR BEGINNING AND ENDING DATES 52 50 ; 53 SEL K SDWLDRG S DIR(0)="Y " S DIR("A")="Do You Want to View Only 'OPEN' Wait Lists",DIR("B")="YES"51 SEL K SDWLDRG S DIR(0)="YAO^^" S DIR("A")="Do You Want to View Only 'OPEN' Wait Lists? Yes// " 54 52 S DIR("?")="'Yes' for 'Open' and these Patient Record have not been dispositioned and 'No' for all Records." 55 53 W ! D ^DIR S SDWLY=Y W ! … … 104 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) 105 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:"") 106 .S SDWLTYN=$S(SDWLTY=1:5,SDWLTY=2:6,SDWLTY=3:7,SDWLTY=4:8 ),SDWLCOM=$P($P(X,U,18),"~",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) 107 105 .S SDWLDUZ=$P(X,U,10),SDWLPRV=$P(X,U,12),SDWLPROV=$P(X,U,13),SDWLX=$P(X,"~",3) D 108 106 ..I $D(SDWLDISX) S SDWLDIS=$P(SDWLDISX,U,1),SDWLDDUZ=$P(SDWLDISX,U,2),SDWLDIDT=$P(SDWLDISX,U,3) … … 165 163 K SDWLDRG,SDWLDT,SDWLDTD,SDWLDTP,SDWLDUZ,SDLWEDT,SDWLIN,SDLWP,SDWLPRI,SDWLPROV,SDLWPRV,SDWLSC,SDWLSP,SDWLSS,SDLWST,SDWLTY 166 164 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,YY168 165 Q -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SDWLQSR.m
r628 r636 1 SDWLQSR ; BPOI/TEH - WAIT LIST STAT REPORT;06/12/022 ;;5.3;scheduling;**263,425,448 ,524**;08/13/93;Build 291 SDWLQSR ;;IOFO BAY PINES/TEH/WAIT LIST STAT REPORT 2 ;;5.3;scheduling;**263,425,448**;AUG 13 1993 3 3 ; 4 4 ; … … 7 7 ; 8 8 EN N ZCODE,ZTDESC,ZTDTH,ZTIO,ZTQUEDED,ZTREQ,ZTRTN,ZTSAVE,ZTSK,POP 9 K ^TMP("SDWLQSR",$J)10 9 D HD 11 10 1 D INS G END:$D(DUOUT) 12 11 2 D DATE G END:$D(DUOUT) 13 3 D EXCL G END:$D(DUOUT)14 12 D QUE G END:$D(DUOUT) 15 13 Q … … 35 33 S ^TMP("SDWLQSR",$J,"DATE")=SDWLBDT_"^"_SDWLEDT K DIR,DIC,DIE,%DT Q 36 34 Q 37 EXCL ;EXCLUDE # REMAINING =0 - PATCH SD*5.3*52438 S SDWLEXCL=0,^TMP("SDWLQSR",$J,"EXCL")=039 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 ^DIR42 I X["^" S DUOUT=1 Q43 I Y<0 S DUOUT=1 Q44 EXCL1 I Y S SDWLEXCL=1,^TMP("SDWLQSR",$J,"EXCL")=SDWLEXCL45 K DIR,X,Y,SDWLEXCL46 Q47 35 QUE ;Queue Report 48 36 N ZTQUEUED,POP … … 60 48 D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" 61 49 Q 62 END D EN^SDWLKIL 63 K DUOUT,SDWLBDT,SDWLEDT,SDWLERR,SDWLIST,SDWLPROM,SDWLTK 64 Q 50 END D EN^SDWLKIL Q 65 51 HD ; 66 52 W:$D(IOF) @IOF W !,?80-$L("Wait List Stat Report")\2,"Wait List Stat Report",! -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SDWLRP4.m
r628 r636 1 1 SDWLRP4 ;IOFO BAY PINES/TEH - WAITING LIST - MERGE RPC;06/28/2002 ; 26 Aug 2002 1:25 PM 2 ;;5.3;scheduling;**263,485,497**;AUG 13 1993;Build 3 2 ;;5.3;scheduling;**263**;AUG 13 1993;Build 4 3 ;Modified from FOIA VISTA, 4 ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU 5 ;General Public License See attached copy of the License. 6 ; 7 ;This program is free software; you can redistribute it and/or modify 8 ;it under the terms of the GNU General Public License as published by 9 ;the Free Software Foundation; either version 2 of the License, or 10 ;(at your option) any later version. 11 ; 12 ;This program is distributed in the hope that it will be useful, 13 ;but WITHOUT ANY WARRANTY; without even the implied warranty of 14 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 ;GNU General Public License for more details. 16 ; 17 ;You should have received a copy of the GNU General Public License along 18 ;with this program; if not, write to the Free Software Foundation, Inc., 19 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 3 20 ; 4 21 INPUT(SDWLRES,SDWLSTR) ; … … 83 100 ;SDWLE=4 = UNDETERMINED 84 101 ; 85 S SDWLDE=+$H,SDWLE= 0,(SDWLEE,SDWLRNED,SDWLDB)=0 D SB1102 S SDWLDE=+$H,SDWLE=1,SDWLEE=0 D SB1 86 103 G SB0:SDWLE=2 87 S SDWLRNE=$$ENROLL^EASWTAPI(SDWLDFN) G SB0:$P(SDWLRNE,U,4)="A"S SDWLRNED=$P(SDWLRNE,U,3)104 S SDWLRNE=$$ENROLL^EASWTAPI(SDWLDFN) S SDWLRNED=$P(SDWLRNE,U,3) 88 105 I SDWLRNED S X=SDWLRNED D H^%DTC S SDWLDS=%H S SDWLDE=+$H,SDWLDET=SDWLDE-SDWLDS I SDWLDET<366 S SDWLE=1 89 106 I $D(SDWLDET),SDWLDET>365 S SDWLE=3 90 107 I 'SDWLRNE S SDWLE=4 91 SB0 I $D(SDWLRNE),$P(SDWLRNE,U,4)="A" D 92 .I 'SDWLEE.SDWLEE>730!(SDWLEE=730) S SDWLE=4 Q 93 .I 'SDWLEE S SDWLE=4 Q 94 S SDWLRNE=$S(SDWLE=1:"N",SDWLE=2:"E",SDWLE=3:"P",SDWLE=4:"U",1:"U") 108 SB0 S SDWLRNE=$S(SDWLE=1:"N",SDWLE=2:"E",SDWLE=3:"P",SDWLE=4:"U") 95 109 ;-Code here for filling in 409.3 96 110 S DR="27////^S X=SDWLRNE",DIE="^SDWL(409.3,",DA=SDWLDA D ^DIE 97 S DR="27.1////^S X=$S($G(SDWLRNED):SDWLRNED,$G(SDWLD):SDWLD,1:"""")" D ^DIE98 S DR="27.2////^S X=SDWLDB" D ^DIE99 111 S DR="9////^S X=DUZ" D ^DIE K DIE,DA,DR,%H 100 K SDWLRNE,SDWLD,SDWLDE,SDWLEE,SDWLDET,DIC,DIR,DR,DIE,SDWLDS,SDWLE,SDWLRNED101 112 Q 102 SB1 I '$D(^DGCN(391.91,"B",SDWLDFN)) N SDWLDBS SDWLE=3 Q113 SB1 I '$D(^DGCN(391.91,"B",SDWLDFN)) S SDWLE=3 Q 103 114 S SDWLX="" F S SDWLX=$O(^DGCN(391.91,"B",SDWLDFN,SDWLX)) Q:SDWLX="" D 104 .S SDWLY=$G(^DGCN(391.91,SDWLX,0)) D 105 ..;CHECK FOR TREATING FACILITY 106 ..I $$TF^XUAF4(+$P(SDWLY,U,2)) D 107 ...;SORT FOR LAST TREATMENT DATE 108 ...S SDWLD=$P(SDWLY,U,3) I SDWLD S SDWLDTF(9999999-SDWLD)=SDWLX 109 I '$D(SDWLDTF) Q 110 S SDWLDTF=$O(SDWLDTF(0)) I SDWLDTF S (SDWLD,X)=9999999-SDWLDTF D H^%DTC S SDWLEE=SDWLDE-%H,SDWLDB=1 I SDWLEE<730 S SDWLE=2 111 I $D(SDWLEE),SDWLEE>730 S SDWLE=3 112 K SDWLDTF 115 .S SDWLY=$G(^DGCN(391.91,SDWLX,0)),SDWLD=$P(^(0),U,3) I SDWLD S X=SDWLD D H^%DTC S SDWLEE=SDWLDE-%H I SDWLEE<730 S SDWLE=2 116 .I $D(SDWLEE),SDWLEE>730 S SDWLE=3 113 117 Q 114 118 FDA ;Get data from SDWLSTR string and set FDA. -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SDWLRSR.m
r628 r636 1 SDWLRSR ; BPOI/TEH - WAIT LIST STAT REPORT;10/01/022 ;;5.3;scheduling;**263,273,399,412,425,415, 524**;08/13/93;Build 291 SDWLRSR ;;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 3 ; 4 4 ; Removed Sort logic as routine exceeded SACC maximum size of 10000 … … 15 15 I $D(DATE) S SDWLDATE=DATE 16 16 I $D(INS) S SDWLINS=INS 17 I $D(EXCL) S SDWLEXCL=EXCL18 17 I $D(ZTSAVE) D 19 .S SDWLCT=$G(ZTSAVE("CT")),SDWLDATE=$G(ZTSAVE("DATE")),SDWLINS=$G(ZTSAVE("INS")) ,SDWLEXCL=$G(ZTSAVE("EXCL"))18 .S SDWLCT=$G(ZTSAVE("CT")),SDWLDATE=$G(ZTSAVE("DATE")),SDWLINS=$G(ZTSAVE("INS")) 20 19 I SDWLINS'="ALL" F I=1:1 S SDWL=$P(SDWLINS,";",I) Q:SDWL="" S SDWL("INS",+SDWL)="" 21 20 S SDWLBD=$P(SDWLDATE,U,1),SDWLED=$P(SDWLDATE,U,2),SDWLPG=0 … … 24 23 Q 25 24 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 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 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 exit29 .I $$S^%ZTLOAD S DUOUT="" Q 30 .W !!,"INSTITUTION: ",SDWLINS,! K ^XTMP("SDWLRSR")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 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) 32 ..S SDWLTNM=$$EXTERNAL^DILFD(409.3,4,,SDWLTY) W !,$E(SDWLTNM,1,15) 33 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*41535 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 36 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 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 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 67 65 Q 68 66 SCR S DIR(0)="E" D ^DIR S:X="^" POP=1 ;SD*5.3*412 69 67 Q 70 68 T1 ; 71 I 'SDWLFLG,SDWLEXCL Q72 W !?20,"---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ----" ;SD*5.3*41573 W !,"Sub-Totals:"74 69 ;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 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 78 74 Q 79 75 T2 W !,"Institution Totals:" 80 W ?2 1,$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*41581 S (TT1,TT2,TT3,TT4,TT5,TT6,TT7,TT8,TT9,TT10,TT11,TT12 )=0 ;SD*5.3*41582 I $Y>(IOSL- 5) D:$D(SDWLSPT) SCR Q:POP D HD,HD1 ;SD*5.3*41276 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 83 79 Q 84 80 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 … … 87 83 Q 88 84 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 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 94 87 Q 95 88 END D EN^SDWLKIL 96 89 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*41598 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*41599 K SDWLOK3,SDWLPR,SDWLPR,SDWLPROM,SDWLRE,SDWLRFDT,SDWLRR,SDWLSA,SDWLSCN,SDWLSCNM,SDWLTASK,SDWLTK,SDWLTNM,SDWLTYNM,SDWLTYP,X4,SDWLTR ;SD*5.3*41590 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 100 93 Q -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SDXA.m
r628 r636 1 SDXA ; GENERATED FROM 'SDAMBT' INPUT TEMPLATE(#491), FILE 409.5; 05/28/971 SDXA ; GENERATED FROM 'SDAMBT' INPUT TEMPLATE(#491), FILE 409.5;12/25/06 2 2 D DE G BEGIN 3 3 DE S DIE="^SDV(",DIC=DIE,DP=409.5,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^SDV(DA,""))="" … … 14 14 B G @DQ 15 15 RE G PR:$D(DE(DQ)) D W,TR 16 N I X="" G A:DV'["R",X:'DV,X:D'>0,A16 N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A 17 17 RD G QS:X?."?" I X["^" D D G ^DIE17 18 18 I X="@" D D G Z^DIE2 … … 20 20 T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V 21 21 K DDER G X 22 P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) I DV'["*" D ^DICS X=+Y,DIC=DIE G X:X<022 P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 23 23 G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z 24 24 I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X 25 25 V D @("X"_DQ) K YS 26 Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A26 Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A 27 27 X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 28 28 S X="?BAD" … … 42 42 D ^DIR I 'DDER S %=Y(0),X=Y 43 43 Q 44 SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) 45 I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" 46 E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") 47 Q 48 NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS 49 KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") 44 50 BEGIN S DNM="SDXA",DQ=1 45 S:$D(DTIME)[0 DTIME=300 S D0=DA,DIEZ=491,U="^" 51 N DIEZTMP,DIEZAR,DIEZRXR,DIIENS,DIXR K DIEFIRE,DIEBADK S DIEZTMP=$$GETTMP^DIKC1("DIEZ") 52 M DIEZAR=^DIE(491,"AR") S DICRREC="TRIG^DIE17" 53 S:$D(DTIME)[0 DTIME=300 S D0=DA,DIIENS=DA_",",DIEZ=491,U="^" 46 54 1 S D=0 K DE(1) ;10 47 S DIFLD=10,DGO="^SDXA1",DC="1 4^409.51P^CS^",DV="409.51P40.7'",DW="0;1",DOW="CLINIC STOP CODE",DLB="Select "_DOW S:D DC=DC_D55 S DIFLD=10,DGO="^SDXA1",DC="15^409.51P^CS^",DV="409.51P40.7'",DW="0;1",DOW="CLINIC STOP CODE",DLB="Select "_DOW S:D DC=DC_D 48 56 S DU="DIC(40.7," 49 57 I $D(DSC(409.51))#2,$P(DSC(409.51),"I $D(^UTILITY(",1)="" X DSC(409.51) S D=$O(^(0)) S:D="" D=-1 G M1 -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SDXA1.m
r628 r636 1 SDXA1 ; ; 05/28/971 SDXA1 ; ;12/25/06 2 2 D DE G BEGIN 3 3 DE S DIE="^SDV(D0,""CS"",",DIC=DIE,DP=409.51,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^SDV(D0,"CS",DA,""))="" 4 4 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,2) S:%]"" DE(1)=% S %=$P(%Z,U,3) S:%]"" DE(2)=% S %=$P(%Z,U,4) S:%]"" DE(3)=% S %=$P(%Z,U,5) S:%]"" DE(4)=% S %=$P(%Z,U,7) S:%]"" DE(5)=% 5 I $D(^("PR")) S %Z=^("PR") S %=$P(%Z,U,1) S:%]"" DE(6)=% S %=$P(%Z,U,2) S:%]"" DE(7)=% S %=$P(%Z,U,3) S:%]"" DE(8)=% S %=$P(%Z,U,4) S:%]"" DE(9)=% S %=$P(%Z,U,5) S:%]"" DE(10)=% 5 6 K %Z Q 6 7 ; … … 15 16 B G @DQ 16 17 RE G PR:$D(DE(DQ)) D W,TR 17 N I X="" G A:DV'["R",X:'DV,X:D'>0,A18 N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A 18 19 RD G QS:X?."?" I X["^" D D G ^DIE17 19 20 I X="@" D D G Z^DIE2 … … 21 22 T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V 22 23 K DDER G X 23 P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) I DV'["*" D ^DICS X=+Y,DIC=DIE G X:X<024 P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 24 25 G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z 25 26 I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X 26 27 V D @("X"_DQ) K YS 27 Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A28 Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A 28 29 X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 29 30 S X="?BAD" … … 43 44 D ^DIR I 'DDER S %=Y(0),X=Y 44 45 Q 46 SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) 47 I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" 48 E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") 49 Q 50 NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS 51 KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") 45 52 BEGIN S DNM="SDXA1",DQ=1 46 53 1 S DW="0;2",DV="P200'",DU="",DLB="EDITED LAST BY",DIFLD=2 … … 48 55 S X=$S($D(DUZ):DUZ,1:"") 49 56 S Y=X 50 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)57 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 51 58 G RD:X="@",Z 52 59 X1 Q … … 55 62 S X=$S($D(SDCL):SDCL,1:"") 56 63 S Y=X 57 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)64 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 58 65 G RD:X="@",Z 59 66 X2 Q … … 63 70 S X=$S(+SDEMP:+SDEMP,'+VAEL(1):"",1:+VAEL(1)) 64 71 S Y=X 65 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)72 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 66 73 G RD:X="@",Z 67 C3 G C3S:$D(DE(3))[0 K DB S X=DE(3),DIC=DIE 74 C3 G C3S:$D(DE(3))[0 K DB 75 S X=DE(3),DIC=DIE 68 76 ; 69 C3S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE 77 C3S S X="" G:DG(DQ)=X C3F1 K DB 78 S X=DG(DQ),DIC=DIE 70 79 K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA X ^DD(409.51,4,1,1,89.2) S Y(101)=$S($D(^SCE(D0,0)):^(0),1:"") S X=$S('$D(^DIC(8,+$P(Y(101),U,13),0)):"",1:$P(^(0),U,1)) S D0=I(0,0) S D1=I(1,0) S DIU=X K Y S X=DIV S X=X X ^DD(409.51,4,1,1,1.4) 71 Q80 C3F1 Q 72 81 X3 Q 73 82 4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW="0;5",DV="R*P409.1'",DU="",DLB="APPOINTMENT TYPE",DIFLD=5 … … 76 85 S X=SDAPTYP 77 86 S Y=X 78 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)87 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 79 88 G RD:X="@",Z 80 C4 G C4S:$D(DE(4))[0 K DB S X=DE(4),DIC=DIE 89 C4 G C4S:$D(DE(4))[0 K DB 90 S X=DE(4),DIC=DIE 81 91 K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(0)=X S X="369"'[X I X S X=DIV S Y(1)=$S($D(^SDV(D0,"CS",D1,0)):^(0),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(409.51,5,1,1,2.4) 82 92 S X=DE(4),DIC=DIE … … 86 96 S X=DE(4),DIC=DIE 87 97 ; 88 C4S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE 98 C4S S X="" G:DG(DQ)=X C4F1 K DB 99 S X=DG(DQ),DIC=DIE 89 100 K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(0)=X S X="369"'[X I X S X=DIV S Y(1)=$S($D(^SDV(D0,"CS",D1,0)):^(0),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y X ^DD(409.51,5,1,1,1.1) X ^DD(409.51,5,1,1,1.4) 90 101 S X=DG(DQ),DIC=DIE … … 94 105 S X=DG(DQ),DIC=DIE 95 106 K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA X ^DD(409.51,5,1,4,89.2) S Y(101)=$S($D(^SCE(D0,0)):^(0),1:"") S X=$S('$D(^SD(409.1,+$P(Y(101),U,10),0)):"",1:$P(^(0),U,1)) S D0=I(0,0) S D1=I(1,0) S DIU=X K Y S X=DIV S X=X X ^DD(409.51,5,1,4,1.4) 96 Q107 C4F1 Q 97 108 X4 Q 98 109 5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW="0;7",DV="D",DU="",DLB="DATE ENTRY MADE",DIFLD=7 99 110 S X=DT 100 111 S Y=X 101 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)112 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 102 113 G RD:X="@",Z 103 114 X5 Q 104 6 D:$D(DG)>9 F^DIE17 G ^SDXA2 115 6 S DW="PR;1",DV="*P81'X",DU="",DLB="PROCEDURE 1",DIFLD=21 116 S DU="ICPT(" 117 S X=$S($D(SDNEW(1)):SDNEW(1),1:"") 118 S Y=X 119 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 120 G RD:X="@",Z 121 X6 Q 122 7 S DW="PR;2",DV="*P81'X",DU="",DLB="PROCEDURE 2",DIFLD=22 123 S DU="ICPT(" 124 S X=$S($D(SDNEW(2)):SDNEW(2),1:"") 125 S Y=X 126 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 127 G RD:X="@",Z 128 X7 Q 129 8 S DW="PR;3",DV="*P81'X",DU="",DLB="PROCEDURE 3",DIFLD=23 130 S DU="ICPT(" 131 S X=$S($D(SDNEW(3)):SDNEW(3),1:"") 132 S Y=X 133 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 134 G RD:X="@",Z 135 X8 Q 136 9 S DW="PR;4",DV="*P81'X",DU="",DLB="PROCEDURE 4",DIFLD=24 137 S DU="ICPT(" 138 S X=$S($D(SDNEW(4)):SDNEW(4),1:"") 139 S Y=X 140 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 141 G RD:X="@",Z 142 X9 Q 143 10 S DW="PR;5",DV="*P81'X",DU="",DLB="PROCEDURE 5",DIFLD=25 144 S DU="ICPT(" 145 S X=$S($D(SDNEW(5)):SDNEW(5),1:"") 146 S Y=X 147 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 148 G RD:X="@",Z 149 X10 Q 150 11 G 1^DIE17 -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SDXACSE.m
r628 r636 1 SDXACSE ; GENERATED FROM 'SDXACSE' INPUT TEMPLATE(#490), FILE 409.5; 05/28/971 SDXACSE ; GENERATED FROM 'SDXACSE' INPUT TEMPLATE(#490), FILE 409.5;12/25/06 2 2 D DE G BEGIN 3 3 DE S DIE="^SDV(",DIC=DIE,DP=409.5,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^SDV(DA,""))="" … … 14 14 B G @DQ 15 15 RE G PR:$D(DE(DQ)) D W,TR 16 N I X="" G A:DV'["R",X:'DV,X:D'>0,A16 N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A 17 17 RD G QS:X?."?" I X["^" D D G ^DIE17 18 18 I X="@" D D G Z^DIE2 … … 20 20 T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V 21 21 K DDER G X 22 P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) I DV'["*" D ^DICS X=+Y,DIC=DIE G X:X<022 P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 23 23 G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z 24 24 I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X 25 25 V D @("X"_DQ) K YS 26 Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A26 Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A 27 27 X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 28 28 S X="?BAD" … … 42 42 D ^DIR I 'DDER S %=Y(0),X=Y 43 43 Q 44 SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) 45 I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" 46 E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") 47 Q 48 NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS 49 KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") 44 50 BEGIN S DNM="SDXACSE",DQ=1 45 S:$D(DTIME)[0 DTIME=300 S D0=DA,DIEZ=490,U="^" 46 1 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=1 D X1 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 51 N DIEZTMP,DIEZAR,DIEZRXR,DIIENS,DIXR K DIEFIRE,DIEBADK S DIEZTMP=$$GETTMP^DIKC1("DIEZ") 52 M DIEZAR=^DIE(490,"AR") S DICRREC="TRIG^DIE17" 53 S:$D(DTIME)[0 DTIME=300 S D0=DA,DIIENS=DA_",",DIEZ=490,U="^" 54 1 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=1 D X1 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 47 55 X1 I '$D(SDAPTYP)!('$D(SDAPTYPR))!('$D(SDCPT))!('$D(SDJ)) W !,*7,"Variables must be defined, edit using option." S Y="@89" 48 56 Q 49 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE1757 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 50 58 X2 I '$S($D(SDUZ):1,$D(DUZ):1,1:0) W !,*7,"User not defined." S Y="@89" 51 59 Q 52 60 3 S D=0 K DE(1) ;10 53 S DIFLD=10,DGO="^SDXACSE1",DC="1 4^409.51P^CS^",DV="409.51P40.7'",DW="0;1",DOW="CLINIC STOP CODE",DLB="Select "_DOW S:D DC=DC_D61 S DIFLD=10,DGO="^SDXACSE1",DC="15^409.51P^CS^",DV="409.51P40.7'",DW="0;1",DOW="CLINIC STOP CODE",DLB="Select "_DOW S:D DC=DC_D 54 62 S DU="DIC(40.7," 55 63 I $D(DSC(409.51))#2,$P(DSC(409.51),"I $D(^UTILITY(",1)="" X DSC(409.51) S D=$O(^(0)) S:D="" D=-1 G M3 -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SDXACSE1.m
r628 r636 1 SDXACSE1 ; ; 05/28/971 SDXACSE1 ; ;12/25/06 2 2 D DE G BEGIN 3 3 DE S DIE="^SDV(D0,""CS"",",DIC=DIE,DP=409.51,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^SDV(D0,"CS",DA,""))="" 4 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,2) S:%]"" DE(1)=% S %=$P(%Z,U,3) S:%]"" DE(2)=% S %=$P(%Z,U,4) S:%]"" DE(3)=% S %=$P(%Z,U,5) S:%]"" DE(4)=% 4 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,2) S:%]"" DE(1)=% S %=$P(%Z,U,3) S:%]"" DE(2)=% S %=$P(%Z,U,4) S:%]"" DE(3)=% S %=$P(%Z,U,5) S:%]"" DE(4)=% S %=$P(%Z,U,6) S:%]"" DE(8)=% 5 I $D(^(1)) S %Z=^(1) S %=$P(%Z,U,1) S:%]"" DE(6)=% 6 I $D(^("PR")) S %Z=^("PR") S %=$P(%Z,U,1) S:%]"" DE(10)=% S %=$P(%Z,U,2) S:%]"" DE(12)=% S %=$P(%Z,U,3) S:%]"" DE(14)=% S %=$P(%Z,U,4) S:%]"" DE(16)=% 5 7 K %Z Q 6 8 ; … … 15 17 B G @DQ 16 18 RE G PR:$D(DE(DQ)) D W,TR 17 N I X="" G A:DV'["R",X:'DV,X:D'>0,A19 N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A 18 20 RD G QS:X?."?" I X["^" D D G ^DIE17 19 21 I X="@" D D G Z^DIE2 … … 21 23 T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V 22 24 K DDER G X 23 P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) I DV'["*" D ^DICS X=+Y,DIC=DIE G X:X<025 P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 24 26 G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z 25 27 I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X 26 28 V D @("X"_DQ) K YS 27 Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A29 Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A 28 30 X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 29 31 S X="?BAD" … … 43 45 D ^DIR I 'DDER S %=Y(0),X=Y 44 46 Q 47 SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) 48 I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" 49 E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") 50 Q 51 NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS 52 KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") 45 53 BEGIN S DNM="SDXACSE1",DQ=1 46 54 1 S DW="0;2",DV="P200'",DU="",DLB="EDITED LAST BY",DIFLD=2 … … 48 56 S X=$S($D(SDUZ):SDUZ,1:DUZ) 49 57 S Y=X 50 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)58 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 51 59 G RD:X="@",Z 52 60 X1 Q … … 55 63 S X=$P(SDCPT(SDJ),U,2) 56 64 S Y=X 57 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)65 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 58 66 G RD:X="@",Z 59 67 X2 Q … … 63 71 S X=$S($G(SDOEP):$P($G(^SCE(SDOEP,0)),U,13),1:"") 64 72 S Y=X 65 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)73 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 66 74 G RD:X="@",Z 67 C3 G C3S:$D(DE(3))[0 K DB S X=DE(3),DIC=DIE 75 C3 G C3S:$D(DE(3))[0 K DB 76 S X=DE(3),DIC=DIE 68 77 ; 69 C3S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE 78 C3S S X="" G:DG(DQ)=X C3F1 K DB 79 S X=DG(DQ),DIC=DIE 70 80 K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA X ^DD(409.51,4,1,1,89.2) S Y(101)=$S($D(^SCE(D0,0)):^(0),1:"") S X=$S('$D(^DIC(8,+$P(Y(101),U,13),0)):"",1:$P(^(0),U,1)) S D0=I(0,0) S D1=I(1,0) S DIU=X K Y S X=DIV S X=X X ^DD(409.51,4,1,1,1.4) 71 Q81 C3F1 Q 72 82 X3 Q 73 83 4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW="0;5",DV="R*P409.1'",DU="",DLB="APPOINTMENT TYPE",DIFLD=5 … … 76 86 S X=SDAPTYP 77 87 S Y=X 78 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)88 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 79 89 G RD:X="@",Z 80 C4 G C4S:$D(DE(4))[0 K DB S X=DE(4),DIC=DIE 90 C4 G C4S:$D(DE(4))[0 K DB 91 S X=DE(4),DIC=DIE 81 92 K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(0)=X S X="369"'[X I X S X=DIV S Y(1)=$S($D(^SDV(D0,"CS",D1,0)):^(0),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(409.51,5,1,1,2.4) 82 93 S X=DE(4),DIC=DIE … … 86 97 S X=DE(4),DIC=DIE 87 98 ; 88 C4S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE 99 C4S S X="" G:DG(DQ)=X C4F1 K DB 100 S X=DG(DQ),DIC=DIE 89 101 K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(0)=X S X="369"'[X I X S X=DIV S Y(1)=$S($D(^SDV(D0,"CS",D1,0)):^(0),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y X ^DD(409.51,5,1,1,1.1) X ^DD(409.51,5,1,1,1.4) 90 102 S X=DG(DQ),DIC=DIE … … 94 106 S X=DG(DQ),DIC=DIE 95 107 K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA X ^DD(409.51,5,1,4,89.2) S Y(101)=$S($D(^SCE(D0,0)):^(0),1:"") S X=$S('$D(^SD(409.1,+$P(Y(101),U,10),0)):"",1:$P(^(0),U,1)) S D0=I(0,0) S D1=I(1,0) S DIU=X K Y S X=DIV S X=X X ^DD(409.51,5,1,4,1.4) 96 Q108 C4F1 Q 97 109 X4 Q 98 5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17110 5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 99 111 X5 I $D(SDNOTCG) S Y="@1" 100 112 Q 101 6 D:$D(DG)>9 F^DIE17 G ^SDXACSE2 113 6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW="1;1",DV="SI",DU="",DLB="COMPUTER GENERATED?",DIFLD=11 114 S DE(DW)="C6^SDXACSE1" 115 S DU="1:YES;" 116 S X=1 117 S Y=X 118 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 119 G RD:X="@",Z 120 C6 G C6S:$D(DE(6))[0 K DB 121 S X=DE(6),DIC=DIE 122 K:X ^SDV("AG",DA(1),DA) 123 C6S S X="" G:DG(DQ)=X C6F1 K DB 124 S X=DG(DQ),DIC=DIE 125 S:X ^SDV("AG",DA(1),DA)="" 126 C6F1 Q 127 X6 Q 128 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 129 X7 I 'SDAPTYPR S Y="@1" 130 Q 131 8 D:$D(DG)>9 F^DIE17,DE S DQ=8,DW="0;6",DV="S",DU="",DLB="UNRESOLVED APPT TYPE REASON",DIFLD=6 132 S DU="1:DUAL ELIGIBILITY;2:POSSIBLE COMP & PEN;" 133 S X=SDAPTYPR 134 S Y=X 135 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 136 G RD:X="@",Z 137 X8 Q 138 9 S DQ=10 ;@1 139 10 S DW="PR;1",DV="*P81'X",DU="",DLB="PROCEDURE 1",DIFLD=21 140 S DU="ICPT(" 141 S X=$P(SDCPT(SDJ),U,3) 142 S Y=X 143 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 144 G RD:X="@",Z 145 X10 Q 146 11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 147 X11 I $P(SDCPT(SDJ),U,4)']"" S Y="@99" 148 Q 149 12 S DW="PR;2",DV="*P81'X",DU="",DLB="PROCEDURE 2",DIFLD=22 150 S DU="ICPT(" 151 S X=$P(SDCPT(SDJ),U,4) 152 S Y=X 153 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 154 G RD:X="@",Z 155 X12 Q 156 13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 157 X13 I $P(SDCPT(SDJ),U,5)']"" S Y="@99" 158 Q 159 14 S DW="PR;3",DV="*P81'X",DU="",DLB="PROCEDURE 3",DIFLD=23 160 S DU="ICPT(" 161 S X=$P(SDCPT(SDJ),U,5) 162 S Y=X 163 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 164 G RD:X="@",Z 165 X14 Q 166 15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 167 X15 I $P(SDCPT(SDJ),U,6)']"" S Y="@99" 168 Q 169 16 S DW="PR;4",DV="*P81'X",DU="",DLB="PROCEDURE 4",DIFLD=24 170 S DU="ICPT(" 171 S X=$P(SDCPT(SDJ),U,6) 172 S Y=X 173 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 174 G RD:X="@",Z 175 X16 Q 176 17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 177 X17 I $P(SDCPT(SDJ),U,7)']"" S Y="@99" 178 Q 179 18 D:$D(DG)>9 F^DIE17 G ^SDXACSE2 -
FOIAVistA/tag/r/SCHEDULING-SD-SC/SDXACSE2.m
r628 r636 1 SDXACSE2 ; ; 05/28/971 SDXACSE2 ; ;12/25/06 2 2 D DE G BEGIN 3 3 DE S DIE="^SDV(D0,""CS"",",DIC=DIE,DP=409.51,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^SDV(D0,"CS",DA,""))="" 4 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,6) S:%]"" DE(3)=% 5 I $D(^(1)) S %Z=^(1) S %=$P(%Z,U,1) S:%]"" DE(1)=% 6 I $D(^("PR")) S %Z=^("PR") S %=$P(%Z,U,1) S:%]"" DE(5)=% S %=$P(%Z,U,2) S:%]"" DE(7)=% S %=$P(%Z,U,3) S:%]"" DE(9)=% S %=$P(%Z,U,4) S:%]"" DE(11)=% S %=$P(%Z,U,5) S:%]"" DE(13)=% 4 I $D(^("PR")) S %Z=^("PR") S %=$P(%Z,U,5) S:%]"" DE(1)=% 7 5 K %Z Q 8 6 ; … … 17 15 B G @DQ 18 16 RE G PR:$D(DE(DQ)) D W,TR 19 N I X="" G A:DV'["R",X:'DV,X:D'>0,A17 N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A 20 18 RD G QS:X?."?" I X["^" D D G ^DIE17 21 19 I X="@" D D G Z^DIE2 … … 23 21 T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V 24 22 K DDER G X 25 P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) I DV'["*" D ^DICS X=+Y,DIC=DIE G X:X<023 P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 26 24 G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z 27 25 I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X 28 26 V D @("X"_DQ) K YS 29 Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A27 Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A 30 28 X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 31 29 S X="?BAD" … … 45 43 D ^DIR I 'DDER S %=Y(0),X=Y 46 44 Q 45 SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) 46 I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" 47 E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") 48 Q 49 NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS 50 KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") 47 51 BEGIN S DNM="SDXACSE2",DQ=1 48 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="1;1",DV="SI",DU="",DLB="COMPUTER GENERATED?",DIFLD=11 49 S DE(DW)="C1^SDXACSE2" 50 S DU="1:YES;" 51 S X=1 52 S Y=X 53 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 54 G RD:X="@",Z 55 C1 G C1S:$D(DE(1))[0 K DB S X=DE(1),DIC=DIE 56 K:X ^SDV("AG",DA(1),DA) 57 C1S S X="" Q:DG(DQ)=X K DB S X=DG(DQ),DIC=DIE 58 S:X ^SDV("AG",DA(1),DA)="" 59 Q 60 X1 Q 61 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 62 X2 I 'SDAPTYPR S Y="@1" 63 Q 64 3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW="0;6",DV="S",DU="",DLB="UNRESOLVED APPT TYPE REASON",DIFLD=6 65 S DU="1:DUAL ELIGIBILITY;2:POSSIBLE COMP & PEN;" 66 S X=SDAPTYPR 67 S Y=X 68 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 69 G RD:X="@",Z 70 X3 Q 71 4 S DQ=5 ;@1 72 5 S DW="PR;1",DV="*P81'X",DU="",DLB="PROCEDURE 1",DIFLD=21 73 S DU="ICPT(" 74 S X=$P(SDCPT(SDJ),U,3) 75 S Y=X 76 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 77 G RD:X="@",Z 78 X5 Q 79 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 80 X6 I $P(SDCPT(SDJ),U,4)']"" S Y="@99" 81 Q 82 7 S DW="PR;2",DV="*P81'X",DU="",DLB="PROCEDURE 2",DIFLD=22 83 S DU="ICPT(" 84 S X=$P(SDCPT(SDJ),U,4) 85 S Y=X 86 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 87 G RD:X="@",Z 88 X7 Q 89 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 90 X8 I $P(SDCPT(SDJ),U,5)']"" S Y="@99" 91 Q 92 9 S DW="PR;3",DV="*P81'X",DU="",DLB="PROCEDURE 3",DIFLD=23 93 S DU="ICPT(" 94 S X=$P(SDCPT(SDJ),U,5) 95 S Y=X 96 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 97 G RD:X="@",Z 98 X9 Q 99 10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 100 X10 I $P(SDCPT(SDJ),U,6)']"" S Y="@99" 101 Q 102 11 S DW="PR;4",DV="*P81'X",DU="",DLB="PROCEDURE 4",DIFLD=24 103 S DU="ICPT(" 104 S X=$P(SDCPT(SDJ),U,6) 105 S Y=X 106 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 107 G RD:X="@",Z 108 X11 Q 109 12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 110 X12 I $P(SDCPT(SDJ),U,7)']"" S Y="@99" 111 Q 112 13 S DW="PR;5",DV="*P81'X",DU="",DLB="PROCEDURE 5",DIFLD=25 52 1 S DW="PR;5",DV="*P81'X",DU="",DLB="PROCEDURE 5",DIFLD=25 113 53 S DU="ICPT(" 114 54 S X=$P(SDCPT(SDJ),U,7) 115 55 S Y=X 116 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)56 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 117 57 G RD:X="@",Z 118 X1 3Q119 14 S DQ=15;@99120 15G 1^DIE1758 X1 Q 59 2 S DQ=3 ;@99 60 3 G 1^DIE17
Note:
See TracChangeset
for help on using the changeset viewer.
