Routine: SCRPTP

SCRPTP ;ALB/CMM - List of Team's Patients ; 29 Jun 99  04:11PM

 ;;5.3;Scheduling;**41,48,174,177,526,520**;AUG 13, 1993;Build 26

PROMPTS ;Prompt for Institution, Team, Role, Patient Status and Print device

 N QTIME,PRNT,VAUTD,VAUTT,VAUTR,VAUTPS,NUMBER

 K SCUP

 S QTIME=""

 W ! D INST^SCRPU1 I Y=-1 G ERR

 W ! K Y D PRMTT^SCRPU1 I '$D(VAUTT) G ERR

 W ! K Y D ROLE^SCRPU1 I '$D(VAUTR) G ERR

 W ! K Y D PTSTAT^SCRPU2 I '$D(VAUTPS) G ERR

 W ! K Y S SORT=$$SORT2^SCRPU2()

 I SORT<1 G ERR

 W !!,"This report requires 132 column output!"

 D QUE(.VAUTD,.VAUTT,.VAUTR,VAUTPS,SORT) Q

QUE(INST,TEAM,ROLE,PSTAT,SORT,IOP,ZTDTH) ;queue report

 ;INST - institutions selected (variable and array)

 ;TEAM - teams selected (variable and array)

 ;ROLE - roles selected (variable and array)

 ;PSTAT - patient status - 1=all or OPT or AC

 ;SORT - 1=d,t,ptname 2=d,t,Pt ID 3=d,t,pract,pt name 4=d,t,pract,Pt ID

 N ZTSAVE,II

 F II="INST","TEAM","ROLE","ROLE(","SORT","PSTAT","INST(","TEAM(" S ZTSAVE(II)=""

 W ! D EN^XUTMDEVQ("QENTRY^SCRPTP","Team Patient Listing",.ZTSAVE)

ENTRY2(INST,TEAM,ROLE,PSTAT,SORT,IOP,ZTDTH) ;Second entry point for GUI to use

 ;INST - institutions selected (variable and array)

 ;TEAM - teams selected (variable and array)

 ;ROLE - roles selected (variable and array)

 ;PSTAT - patient status - 1=all or OPT or AC

 ;SORT - 1=d,t,ptname 2=d,t,Pt ID 3=d,t,pract,pt name 4=d,t,pract,Pt ID

 ;IOP - print device

 ;ZTDTH - queue time (optional)

 ;validate parameters

 I '$D(INST)!'$D(TEAM)!'$D(ROLE)!'$D(PSTAT)!'$D(SORT)!'$D(IOP)!(IOP="") Q

 N NUMBER

 S IOST=$P(IOP,"^",2),IOP=$P(IOP,"^")

 I IOP?1"Q;".E S IOP=$P(IOP,"Q;",2)

 I IOST?1"C-".E D QENTRY G RET

 I ZTDTH="" S ZTDTH=$H

 S ZTRTN="QENTRY^SCRPTP"

 S ZTDESC="List of Team's Patients",ZTIO=IOP

 N II

 F II="INST","TEAM","ROLE","ROLE(","SORT","PSTAT","INST(","TEAM(","IOP" S ZTSAVE(II)=""

 D ^%ZTLOAD

RET S NUMBER=0

 I $D(ZTSK) S NUMBER=ZTSK

 D EXIT1

 Q NUMBER

QENTRY ;driver entry point

 S TITL="Team Patient Listing",STORE="^TMP("_$J_",""SCRPTP"")"

 K @STORE

 S @STORE=0

 D FIND

 I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL)

 I '$D(NODATA) D PRINTIT^SCRPTP2(STORE,TITL)

 D EXIT2

ERR ;

EXIT1 ;

 K ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE,SCUP

EXIT2 ;

 K @STORE

 K STOP,STORE,TITL,IOP,TEAM,INST,ROLE,PSTAT,SORT,NODATA

FIND ;

 N TIEN,ERR,LIST,OKAY

 I TEAM=1 D TALL^SCRPPAT3 ;gets all teams for all divisions selected

 S TIEN="",LIST="^TMP("_$J_",""SCRPTP ARRAY"")",ERR="ERROR"

 K @LIST,@ERR

 F  S TIEN=$O(TEAM(TIEN)) Q:TIEN=""  D

 .;TIEN - team ien

 .S OKAY=$$PTTM^SCAPMC2(TIEN,"",LIST,ERR)

 .; gets all patients for given team

 .D HITS^SCRPTP3(LIST,TIEN)

 .K @LIST,@ERR

 K @LIST,@ERR

TINF(TIEN) ;team information

 ;TIEN - team ien

 ;returns: institution ien ^ team name ^ primary care ^ team phone

 N PC,PHONE,TNODE,TNAME

 S TNODE=$G(^SCTM(404.51,TIEN,0))

 S TNAME=$P(TNODE,"^") ;team name

 S PC=$S($P(TNODE,"^",5)=1:"YES",1:"NO") ;primary care team

 S PHONE=$P(TNODE,"^",2) ;team phone

 S INS=+$P(TNODE,"^",7) ;institution ien

 D TDESC^SCRPITP2(TIEN,INS) ;gets team description

 Q INS_"^"_TNAME_"^"_PC_"^"_PHONE

PST(PTIEN,CLIEN) ;

 ;PTIEN - patient ien

 ;CLIEN - associated clinic ien

 ;returns 1=selected patient status, 0=not selected patient status

 N EN,NXT,FOUND,ENODE

 S EN="",(FOUND,NXT)=0

 Q:'$D(^DPT(PTIEN,"DE","B",CLIEN)) FOUND

 S EN=$O(^DPT(PTIEN,"DE","B",CLIEN,""))

 I EN=""&(PSTAT=1) S FOUND=1 Q FOUND

 Q:EN=""!'$D(^DPT(PTIEN,"DE",EN,1)) FOUND

 F  S NXT=$O(^DPT(PTIEN,"DE",EN,1,NXT)) Q:(FOUND)!(NXT="")!(NXT'?.N)  D

 .;check if active enrollment

 .S ENODE=$G(^DPT(PTIEN,"DE",EN,1,NXT,0))

 .I $P(ENODE,"^",3)'="",$P(ENODE,"^",3)<DT+1!$P(ENODE,"^")>DT Q  ;not active enrollment

 .;                      ^ discharge date     ^ enrollment date

 .Q:$P(ENODE,"^",2)'=$E(PSTAT,1)&(PSTAT'=1)  ;not selected patient status

 .S FOUND=1

 Q FOUND

FORMAT(INS,TIEN,PTIEN,PTNAME,PID,PIEN,PNAME,CNAME,PINF,ROLN,PCAP) ;Format column information

 ;INS - Institution ien

 ;TIEN - team ien

 ;PTIEN - patient ien

 ;PTNAME - patient name

 ;PID - SSN

 ;PIEN - practitioner ien

 ;PNAME - practitioner name

 ;CNAME - clinic name

 ;LAST - last appointment

 ;NEXT - next appointment

 ;ROLN - role name

 ;PCAP - PC?

 N SEC,TRD

 I PNAME="" S PNAME="[BAD DATA]"

 I PTNAME="" S PTNAME="[BAD DATA]"

 I PID="" S PID="*********"

 S @STORE@("P",INS,TIEN,PNAME,PIEN)="" ;practitioner

 S @STORE@("PT",INS,TIEN,PTNAME,PTIEN)="" ;patient

 S @STORE@("PID",INS,TIEN,PID,PTIEN)=""

 I (SORT=1)!(SORT=2) S SEC=PTIEN,TRD=PIEN ;sort doesn't include practitioner

 I (SORT=3)!(SORT=4) S SEC=PIEN,TRD=PTIEN ;sort includes practitioner

 S @STORE@(INS,TIEN,SEC,TRD)=$E(PTNAME,1,15) ;patient name

 S $E(@STORE@(INS,TIEN,SEC,TRD),18)=PID ;9 digit pid

 S $E(@STORE@(INS,TIEN,SEC,TRD),32)=$E(PNAME,1,22) ;practitioner name

 S $E(@STORE@(INS,TIEN,SEC,TRD),56)=$E($G(ROLN),1,22) ;role name

 S $E(@STORE@(INS,TIEN,SEC,TRD),80)=$G(PCAP) ;PC?

 S $E(@STORE@(INS,TIEN,SEC,TRD),85)=$P(PINF,"^",8) ;last appointment

 S $E(@STORE@(INS,TIEN,SEC,TRD),97)=$P(PINF,"^",9) ;next appointment

 S $E(@STORE@(INS,TIEN,SEC,TRD),109)=$E(CNAME,1,24) ;clinic name

FORMATAC(SCCNT,CNAME,PINF,INS,TIEN,PTIEN,PTNAME,PID,PIEN,PNAME,ROLN,PCAP) ;Format MULTIPLES

 ;INS - Institution ien

 ;TIEN - team ien

 ;PTIEN - patient ien

 ;PTNAME - patient name

 ;PID - last 4 PID - includes pseudo notation as 5th

 ;PIEN - practitioner ien

 ;PNAME - practitioner name

 ;CNAME - clinic name

 ;LAST - last appointment

 ;NEXT - next appointment

 ;ROLN - role name

 ;PCAP - PC?

 N SEC,TRD

 I PNAME="" S PNAME="[BAD DATA]"

 I PTNAME="" S PTNAME="[BAD DATA]"

 I PID="" S PID="****"

 S @STORE@("P",INS,TIEN,PNAME,PIEN)="" ;practitioner

 S @STORE@("PT",INS,TIEN,PTNAME,PTIEN)="" ;patient

 S @STORE@("PID",INS,TIEN,PID,PTIEN)="" ;last 4 pid

 N TRD

 I (SORT=1)!(SORT=2) S SEC=PTIEN,TRD=PIEN ;sort doesn't include practitioner

 I (SORT=3)!(SORT=4) S SEC=PIEN,TRD=PTIEN ;sort includes practitioner

 I '$D(@STORE@(INS,TIEN,SEC,TRD,SCCNT))  D

 .S $E(@STORE@(INS,TIEN,SEC,TRD,SCCNT),85)=$P(PINF,"^",8) ;last appointment

 .S $E(@STORE@(INS,TIEN,SEC,TRD,SCCNT),97)=$P(PINF,"^",9) ;next appointment

 .S $E(@STORE@(INS,TIEN,SEC,TRD,SCCNT),109)=$E(CNAME,1,24) ;clinic name

.Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCRPTP   6361     printed  Feb 19, 2025@00:09:30                                                                                                                                                                                                      Page 2

SCRPTP    ;ALB/CMM - List of Team's Patients ; 29 Jun 99  04:11PM

 +1       ;;5.3;Scheduling;**41,48,174,177,526,520**;AUG 13, 1993;Build 26

 +2       ;

PROMPTS   ;Prompt for Institution, Team, Role, Patient Status and Print device

 +1        NEW QTIME,PRNT,VAUTD,VAUTT,VAUTR,VAUTPS,NUMBER

 +2        KILL SCUP

 +3        SET QTIME=""

 +4        WRITE !

           DO INST^SCRPU1

           IF Y=-1

               GOTO ERR

 +5        WRITE !

           KILL Y

           DO PRMTT^SCRPU1

           IF '$DATA(VAUTT)

               GOTO ERR

 +6        WRITE !

           KILL Y

           DO ROLE^SCRPU1

           IF '$DATA(VAUTR)

               GOTO ERR

 +7        WRITE !

           KILL Y

           DO PTSTAT^SCRPU2

           IF '$DATA(VAUTPS)

               GOTO ERR

 +8        WRITE !

           KILL Y

           SET SORT=$$SORT2^SCRPU2()

 +9        IF SORT<1

               GOTO ERR

 +10       WRITE !!,"This report requires 132 column output!"

 +11       DO QUE(.VAUTD,.VAUTT,.VAUTR,VAUTPS,SORT)

           QUIT

 +12      ;

QUE(INST,TEAM,ROLE,PSTAT,SORT,IOP,ZTDTH) ;queue report

 +1       ;INST - institutions selected (variable and array)

 +2       ;TEAM - teams selected (variable and array)

 +3       ;ROLE - roles selected (variable and array)

 +4       ;PSTAT - patient status - 1=all or OPT or AC

 +5       ;SORT - 1=d,t,ptname 2=d,t,Pt ID 3=d,t,pract,pt name 4=d,t,pract,Pt ID

 +6        NEW ZTSAVE,II

 +7        FOR II="INST","TEAM","ROLE","ROLE(","SORT","PSTAT","INST(","TEAM("

               SET ZTSAVE(II)=""

 +8        WRITE !

           DO EN^XUTMDEVQ("QENTRY^SCRPTP","Team Patient Listing",.ZTSAVE)

 +9        QUIT

 +10      ;

ENTRY2(INST,TEAM,ROLE,PSTAT,SORT,IOP,ZTDTH) ;Second entry point for GUI to use

 +1       ;INST - institutions selected (variable and array)

 +2       ;TEAM - teams selected (variable and array)

 +3       ;ROLE - roles selected (variable and array)

 +4       ;PSTAT - patient status - 1=all or OPT or AC

 +5       ;SORT - 1=d,t,ptname 2=d,t,Pt ID 3=d,t,pract,pt name 4=d,t,pract,Pt ID

 +6       ;IOP - print device

 +7       ;ZTDTH - queue time (optional)

 +8       ;

 +9       ;validate parameters

 +10       IF '$DATA(INST)!'$DATA(TEAM)!'$DATA(ROLE)!'$DATA(PSTAT)!'$DATA(SORT)!'$DATA(IOP)!(IOP="")

               QUIT

 +11       NEW NUMBER

 +12       SET IOST=$PIECE(IOP,"^",2)

           SET IOP=$PIECE(IOP,"^")

 +13       IF IOP?1"Q;".E

               SET IOP=$PIECE(IOP,"Q;",2)

 +14       IF IOST?1"C-".E

               DO QENTRY

               GOTO RET

 +15       IF ZTDTH=""

               SET ZTDTH=$HOROLOG

 +16       SET ZTRTN="QENTRY^SCRPTP"

 +17       SET ZTDESC="List of Team's Patients"

           SET ZTIO=IOP

 +18       NEW II

 +19       FOR II="INST","TEAM","ROLE","ROLE(","SORT","PSTAT","INST(","TEAM(","IOP"

               SET ZTSAVE(II)=""

 +20       DO ^%ZTLOAD

RET        SET NUMBER=0

 +1        IF $DATA(ZTSK)

               SET NUMBER=ZTSK

 +2        DO EXIT1

 +3        QUIT NUMBER

 +4       ;

QENTRY    ;driver entry point

 +1        SET TITL="Team Patient Listing"

           SET STORE="^TMP("_$JOB_",""SCRPTP"")"

 +2        KILL @STORE

 +3        SET @STORE=0

 +4        DO FIND

 +5        IF $ORDER(@STORE@(0))=""

               SET NODATA=$$NODATA^SCRPU3(TITL)

 +6        IF '$DATA(NODATA)

               DO PRINTIT^SCRPTP2(STORE,TITL)

 +7        DO EXIT2

 +8        QUIT

ERR       ;

EXIT1     ;

 +1        KILL ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE,SCUP

 +2        QUIT

EXIT2     ;

 +1        KILL @STORE

 +2        KILL STOP,STORE,TITL,IOP,TEAM,INST,ROLE,PSTAT,SORT,NODATA

 +3        QUIT

FIND      ;

 +1        NEW TIEN,ERR,LIST,OKAY

 +2       ;gets all teams for all divisions selected

           IF TEAM=1

               DO TALL^SCRPPAT3

 +3        SET TIEN=""

           SET LIST="^TMP("_$JOB_",""SCRPTP ARRAY"")"

           SET ERR="ERROR"

 +4        KILL @LIST,@ERR

 +5        FOR

               SET TIEN=$ORDER(TEAM(TIEN))

               if TIEN=""

                   QUIT

               Begin DoDot:1

 +6       ;TIEN - team ien

 +7                SET OKAY=$$PTTM^SCAPMC2(TIEN,"",LIST,ERR)

 +8       ; gets all patients for given team

 +9                DO HITS^SCRPTP3(LIST,TIEN)

 +10               KILL @LIST,@ERR

               End DoDot:1

 +11       KILL @LIST,@ERR

 +12       QUIT

TINF(TIEN) ;team information

 +1       ;TIEN - team ien

 +2       ;returns: institution ien ^ team name ^ primary care ^ team phone

 +3        NEW PC,PHONE,TNODE,TNAME

 +4        SET TNODE=$GET(^SCTM(404.51,TIEN,0))

 +5       ;team name

           SET TNAME=$PIECE(TNODE,"^")

 +6       ;primary care team

           SET PC=$SELECT($PIECE(TNODE,"^",5)=1:"YES",1:"NO")

 +7       ;team phone

           SET PHONE=$PIECE(TNODE,"^",2)

 +8       ;institution ien

           SET INS=+$PIECE(TNODE,"^",7)

 +9       ;gets team description

           DO TDESC^SCRPITP2(TIEN,INS)

 +10       QUIT INS_"^"_TNAME_"^"_PC_"^"_PHONE

 +11      ;

PST(PTIEN,CLIEN) ;

 +1       ;PTIEN - patient ien

 +2       ;CLIEN - associated clinic ien

 +3       ;returns 1=selected patient status, 0=not selected patient status

 +4       ;

 +5        NEW EN,NXT,FOUND,ENODE

 +6        SET EN=""

           SET (FOUND,NXT)=0

 +7        if '$DATA(^DPT(PTIEN,"DE","B",CLIEN))

               QUIT FOUND

 +8        SET EN=$ORDER(^DPT(PTIEN,"DE","B",CLIEN,""))

 +9        IF EN=""&(PSTAT=1)

               SET FOUND=1

               QUIT FOUND

 +10       if EN=""!'$DATA(^DPT(PTIEN,"DE",EN,1))

               QUIT FOUND

 +11       FOR

               SET NXT=$ORDER(^DPT(PTIEN,"DE",EN,1,NXT))

               if (FOUND)!(NXT="")!(NXT'?.N)

                   QUIT

               Begin DoDot:1

 +12      ;check if active enrollment

 +13               SET ENODE=$GET(^DPT(PTIEN,"DE",EN,1,NXT,0))

 +14      ;not active enrollment

                   IF $PIECE(ENODE,"^",3)'=""

                       IF $PIECE(ENODE,"^",3)<DT+1!$PIECE(ENODE,"^")>DT

                           QUIT

 +15      ;                      ^ discharge date     ^ enrollment date

 +16      ;not selected patient status

                   if $PIECE(ENODE,"^",2)'=$EXTRACT(PSTAT,1)&(PSTAT'=1)

                       QUIT

 +17               SET FOUND=1

               End DoDot:1

 +18       QUIT FOUND

 +19      ;

FORMAT(INS,TIEN,PTIEN,PTNAME,PID,PIEN,PNAME,CNAME,PINF,ROLN,PCAP) ;Format column information

 +1       ;INS - Institution ien

 +2       ;TIEN - team ien

 +3       ;PTIEN - patient ien

 +4       ;PTNAME - patient name

 +5       ;PID - SSN

 +6       ;PIEN - practitioner ien

 +7       ;PNAME - practitioner name

 +8       ;CNAME - clinic name

 +9       ;LAST - last appointment

 +10      ;NEXT - next appointment

 +11      ;ROLN - role name

 +12      ;PCAP - PC?

 +13      ;

 +14       NEW SEC,TRD

 +15       IF PNAME=""

               SET PNAME="[BAD DATA]"

 +16       IF PTNAME=""

               SET PTNAME="[BAD DATA]"

 +17       IF PID=""

               SET PID="*********"

 +18      ;practitioner

           SET @STORE@("P",INS,TIEN,PNAME,PIEN)=""

 +19      ;patient

           SET @STORE@("PT",INS,TIEN,PTNAME,PTIEN)=""

 +20       SET @STORE@("PID",INS,TIEN,PID,PTIEN)=""

 +21      ;sort doesn't include practitioner

           IF (SORT=1)!(SORT=2)

               SET SEC=PTIEN

               SET TRD=PIEN

 +22      ;sort includes practitioner

           IF (SORT=3)!(SORT=4)

               SET SEC=PIEN

               SET TRD=PTIEN

 +23      ;patient name

           SET @STORE@(INS,TIEN,SEC,TRD)=$EXTRACT(PTNAME,1,15)

 +24      ;9 digit pid

           SET $EXTRACT(@STORE@(INS,TIEN,SEC,TRD),18)=PID

 +25      ;practitioner name

           SET $EXTRACT(@STORE@(INS,TIEN,SEC,TRD),32)=$EXTRACT(PNAME,1,22)

 +26      ;role name

           SET $EXTRACT(@STORE@(INS,TIEN,SEC,TRD),56)=$EXTRACT($GET(ROLN),1,22)

 +27      ;PC?

           SET $EXTRACT(@STORE@(INS,TIEN,SEC,TRD),80)=$GET(PCAP)

 +28      ;last appointment

           SET $EXTRACT(@STORE@(INS,TIEN,SEC,TRD),85)=$PIECE(PINF,"^",8)

 +29      ;next appointment

           SET $EXTRACT(@STORE@(INS,TIEN,SEC,TRD),97)=$PIECE(PINF,"^",9)

 +30      ;clinic name

           SET $EXTRACT(@STORE@(INS,TIEN,SEC,TRD),109)=$EXTRACT(CNAME,1,24)

 +31       QUIT

FORMATAC(SCCNT,CNAME,PINF,INS,TIEN,PTIEN,PTNAME,PID,PIEN,PNAME,ROLN,PCAP) ;Format MULTIPLES

 +1       ;INS - Institution ien

 +2       ;TIEN - team ien

 +3       ;PTIEN - patient ien

 +4       ;PTNAME - patient name

 +5       ;PID - last 4 PID - includes pseudo notation as 5th

 +6       ;PIEN - practitioner ien

 +7       ;PNAME - practitioner name

 +8       ;CNAME - clinic name

 +9       ;LAST - last appointment

 +10      ;NEXT - next appointment

 +11      ;ROLN - role name

 +12      ;PCAP - PC?

 +13      ;

 +14       NEW SEC,TRD

 +15       IF PNAME=""

               SET PNAME="[BAD DATA]"

 +16       IF PTNAME=""

               SET PTNAME="[BAD DATA]"

 +17       IF PID=""

               SET PID="****"

 +18      ;practitioner

           SET @STORE@("P",INS,TIEN,PNAME,PIEN)=""

 +19      ;patient

           SET @STORE@("PT",INS,TIEN,PTNAME,PTIEN)=""

 +20      ;last 4 pid

           SET @STORE@("PID",INS,TIEN,PID,PTIEN)=""

 +21       NEW TRD

 +22      ;sort doesn't include practitioner

           IF (SORT=1)!(SORT=2)

               SET SEC=PTIEN

               SET TRD=PIEN

 +23      ;sort includes practitioner

           IF (SORT=3)!(SORT=4)

               SET SEC=PIEN

               SET TRD=PTIEN

 +24       IF '$DATA(@STORE@(INS,TIEN,SEC,TRD,SCCNT))

               Begin DoDot:1

 +25      ;last appointment

                   SET $EXTRACT(@STORE@(INS,TIEN,SEC,TRD,SCCNT),85)=$PIECE(PINF,"^",8)

 +26      ;next appointment

                   SET $EXTRACT(@STORE@(INS,TIEN,SEC,TRD,SCCNT),97)=$PIECE(PINF,"^",9)

 +27      ;clinic name

                   SET $EXTRACT(@STORE@(INS,TIEN,SEC,TRD,SCCNT),109)=$EXTRACT(CNAME,1,24)

 +28               QUIT

               End DoDot:1

 +29       QUIT

SCRPTP.m