SROPCE0B ;BIR/ADM - PCE FILING STATUS REPORT, SHORT FORM ;12/16/98 2:10 PM
;;3.0; Surgery ;**58,62,69,77,50,86,118,142**;24 Jun 93
;
; Reference to ^ECC(723 supported by DBIA #205
; Reference to ^SCE("AVSIT" supported by DBIA #2045
; Reference to File #409.68 supported by DBIA #2045
;
D HDR F S SRSDT=$O(^SRF("AC",SRSDT)) Q:'SRSDT!(SRSDT>SRSEDT)!SRSOUT S SRTN=0 F S SRTN=$O(^SRF("AC",SRSDT,SRTN)) Q:'SRTN I $D(^SRF(SRTN,0)),$$DIV^SROUTL0(SRTN),$P($G(^SRF(SRTN,30)),"^")="" D UTIL Q:SRSOUT
D:'SRSOUT TOTAL
Q
TOTAL D:$Y+9>IOSL PAGE Q:SRSOUT W !!,?13,"FILED: ",$J(CNT(1),5),!,?9,"NOT FILED: "_$J(CNT(4),5)
F I=1:1:5 S CNT(6)=CNT(6)+CNT(I)
W:CNT(5) !,?9,"UNCERTAIN: "_$J(CNT(5),5) W !,?20,"-----",!,?7,"TOTAL CASES: ",$J(CNT(6),5)
Q
UTIL ; process case
S SRDIV=$P($G(^SRF(SRTN,8)),"^") I SRDIV S SRSPS=$O(^SRO(133,"B",SRDIV,0))
I 'SRDIV S SRSPS=SRSITE
S X=^SRO(133,SRSPS,0),SRPARAM=$P(X,"^",15),SRSR=$P(X,"^",19) I SRPARAM=""!(SRPARAM="N") Q
S SRINOUT=$P(^SRF(SRTN,0),"^",12) I SRPARAM="O",SRINOUT'="",SRINOUT'="O" Q
S SRNON=0 I $P($G(^SRF(SRTN,"NON")),"^")="Y" S SRNON=1
I SRFLG=1!(SRFLG=3&('SRNON)),'$P($G(^SRF(SRTN,.2)),"^",12) Q
I SRFLG=2!(SRFLG=3&SRNON),'$P($G(^SRF(SRTN,"NON")),"^",5) Q
I (SRFLG=2&('SRNON))!(SRFLG=1&(SRNON)) Q
S SRSS=$S('SRNON:$P(^SRF(SRTN,0),"^",4),1:$P(^SRF(SRTN,"NON"),"^",8)) I SRSPEC,SRSPEC'=SRSS Q
S SRSSNM=$S('SRNON:$P(^SRO(137.45,SRSS,0),"^"),1:$P(^ECC(723,SRSS,0),"^"))
I SRPARAM="O",SRINOUT="" S SRSTATUS=5,CNT(5)=CNT(5)+1 D CASE,CHK^SROPCE0,MISS Q
I $P(^SRF(SRTN,0),"^",15) S SRSTATUS=1,CNT(1)=CNT(1)+1 D CASE,LINE Q
S SRSTATUS=4,CNT(4)=CNT(4)+1 D CASE,CHK^SROPCE0,MISS
Q
MISS ; list fields missing data
Q:SRSOUT S SRFLD="" S SRFLD=$O(SRX(SRFLD)) I SRFLD="" W !,?15,"No Missing Information" D LINE Q
S SRCT=1,SRFLD="" W !!,?15,"Missing Information:" F S SRFLD=$O(SRX(SRFLD)) Q:SRFLD="" D:$Y+5>IOSL PAGE Q:SRSOUT W !,$J(SRCT_". ",20),SRX(SRFLD) S SRCT=SRCT+1
LINE I 'SRSOUT W ! F I=1:1:80 W "-"
Q
SCHED ; get appointment status from Scheduling
N SRENC,SRVSIT,SRX S SRSCHED="<NONE>",SRVSIT=$P(SR(0),"^",15) Q:'SRVSIT
S SRENC=$O(^SCE("AVSIT",SRVSIT,0)) Q:'SRENC
S DA=SRENC,DIC=409.68,DR=".12",DIQ="SRX",DIQ(0)="E" D EN^DIQ1 K DA,DIC,DIQ,DR
I SRX(409.68,SRENC,.12,"E")="INPATIENT APPOINTMENT" S SRX(409.68,SRENC,.12,"E")="INPATIENT APPT"
S X=SRX(409.68,SRENC,.12,"E") I X'="" S SRSCHED=X
Q
CASE ; print case info
D:$Y+9>IOSL PAGE Q:SRSOUT D DEM,PROC,SCHED
W !,SRSDATE,?22,SRSNM,?44,SRSSN_" ("_SRAGE_")",?66,$S(SRSTATUS=1:"FILED",SRSTATUS=4:"NOT FILED",1:"UNCERTAIN")
W !,SRTN,?22,$E(SRSSNM,1,20),?66,$E(SRSCHED,1,14),! W:(SRFLG=3)&SRNON "NON-O.R." W ?22,SRPROC(1) W:$D(SRPROC(2)) !,?22,SRPROC(2) W:$D(SRPROC(3)) !,?22,SRPROC(3)
Q
DEM ; get patient demographic information
S SR(0)=^SRF(SRTN,0),DFN=$P(SR(0),"^") D DEM^VADPT S SRSNM=VADM(1),SRSSN=VA("PID"),Y=SRSDT X ^DD("DD") S SRSDATE=Y,X1=$E(SRSDT,1,7),X2=$P(VADM(3),"^"),SRAGE=$E(X1,1,3)-$E(X2,1,3)-($E(X1,4,7)<$E(X2,4,7))
I $L(SRSNM)>20 S SRSNM=$P(VADM(1),",")_","_$E($P(VADM(1),",",2))_"."
Q
PROC ; get principal procedure
K SRPROC S X=$P(^SRF(SRTN,"OP"),"^") I $L(X)<56 S SRPROC(1)=X
I $L(X)>55 S K=1 F D I $L(X)<56 S SRPROC(K)=X Q
.F I=0:1:54 S J=55-I,Y=$E(X,J) I Y=" " S SRPROC(K)=$E(X,1,J-1),X=$E(X,J+1,$L(X)) S K=K+1 Q
Q
PAGE I $E(IOST)="P"!SRHDR G HDR
W ! K DIR S DIR(0)="E" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q
HDR ; print heading
I $D(ZTQUEUED) D ^SROSTOP I SRHALT S SRSOUT=1 Q
W:$Y @IOF W:$E(IOST)="P" !,?(80-$L(SRINST)\2),SRINST W !,?(80-$L(SRRPT)\2),SRRPT,?70,$J("PAGE "_SRPAGE,9),!,?(80-$L(SRTITLE)\2),SRTITLE,!,?(80-$L(SRFRTO)\2),SRFRTO W:$E(IOST)="P" !,?(80-$L(SRPRINT)\2),SRPRINT
W !!,"DATE OF "_$S(SRFLG=1:"OPERATION",SRFLG=2:"PROCEDURE",1:"OP/PROCEDURE"),?22,"PATIENT NAME",?44,"PATIENT ID (AGE)",?66,"FILING STATUS",!,"CASE #",?22,"SPECIALTY",?66,"SCHED STATUS",!,?22,"PRINCIPAL PROCEDURE"
S SRHDR=0,SRPAGE=SRPAGE+1 W ! F I=1:1:80 W "="
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROPCE0B 3980 printed Apr 09, 2024@21:43 Page 2
SROPCE0B ;BIR/ADM - PCE FILING STATUS REPORT, SHORT FORM ;12/16/98 2:10 PM
+1 ;;3.0; Surgery ;**58,62,69,77,50,86,118,142**;24 Jun 93
+2 ;
+3 ; Reference to ^ECC(723 supported by DBIA #205
+4 ; Reference to ^SCE("AVSIT" supported by DBIA #2045
+5 ; Reference to File #409.68 supported by DBIA #2045
+6 ;
+7 DO HDR
FOR
SET SRSDT=$ORDER(^SRF("AC",SRSDT))
if 'SRSDT!(SRSDT>SRSEDT)!SRSOUT
QUIT
SET SRTN=0
FOR
SET SRTN=$ORDER(^SRF("AC",SRSDT,SRTN))
if 'SRTN
QUIT
IF $DATA(^SRF(SRTN,0))
IF $$DIV^SROUTL0(SRTN)
IF $PIECE($GET(^SRF(SRTN,30)),"^")=""
DO UTIL
if SRSOUT
QUIT
+8 if 'SRSOUT
DO TOTAL
+9 QUIT
TOTAL if $Y+9>IOSL
DO PAGE
if SRSOUT
QUIT
WRITE !!,?13,"FILED: ",$JUSTIFY(CNT(1),5),!,?9,"NOT FILED: "_$JUSTIFY(CNT(4),5)
+1 FOR I=1:1:5
SET CNT(6)=CNT(6)+CNT(I)
+2 if CNT(5)
WRITE !,?9,"UNCERTAIN: "_$JUSTIFY(CNT(5),5)
WRITE !,?20,"-----",!,?7,"TOTAL CASES: ",$JUSTIFY(CNT(6),5)
+3 QUIT
UTIL ; process case
+1 SET SRDIV=$PIECE($GET(^SRF(SRTN,8)),"^")
IF SRDIV
SET SRSPS=$ORDER(^SRO(133,"B",SRDIV,0))
+2 IF 'SRDIV
SET SRSPS=SRSITE
+3 SET X=^SRO(133,SRSPS,0)
SET SRPARAM=$PIECE(X,"^",15)
SET SRSR=$PIECE(X,"^",19)
IF SRPARAM=""!(SRPARAM="N")
QUIT
+4 SET SRINOUT=$PIECE(^SRF(SRTN,0),"^",12)
IF SRPARAM="O"
IF SRINOUT'=""
IF SRINOUT'="O"
QUIT
+5 SET SRNON=0
IF $PIECE($GET(^SRF(SRTN,"NON")),"^")="Y"
SET SRNON=1
+6 IF SRFLG=1!(SRFLG=3&('SRNON))
IF '$PIECE($GET(^SRF(SRTN,.2)),"^",12)
QUIT
+7 IF SRFLG=2!(SRFLG=3&SRNON)
IF '$PIECE($GET(^SRF(SRTN,"NON")),"^",5)
QUIT
+8 IF (SRFLG=2&('SRNON))!(SRFLG=1&(SRNON))
QUIT
+9 SET SRSS=$SELECT('SRNON:$PIECE(^SRF(SRTN,0),"^",4),1:$PIECE(^SRF(SRTN,"NON"),"^",8))
IF SRSPEC
IF SRSPEC'=SRSS
QUIT
+10 SET SRSSNM=$SELECT('SRNON:$PIECE(^SRO(137.45,SRSS,0),"^"),1:$PIECE(^ECC(723,SRSS,0),"^"))
+11 IF SRPARAM="O"
IF SRINOUT=""
SET SRSTATUS=5
SET CNT(5)=CNT(5)+1
DO CASE
DO CHK^SROPCE0
DO MISS
QUIT
+12 IF $PIECE(^SRF(SRTN,0),"^",15)
SET SRSTATUS=1
SET CNT(1)=CNT(1)+1
DO CASE
DO LINE
QUIT
+13 SET SRSTATUS=4
SET CNT(4)=CNT(4)+1
DO CASE
DO CHK^SROPCE0
DO MISS
+14 QUIT
MISS ; list fields missing data
+1 if SRSOUT
QUIT
SET SRFLD=""
SET SRFLD=$ORDER(SRX(SRFLD))
IF SRFLD=""
WRITE !,?15,"No Missing Information"
DO LINE
QUIT
+2 SET SRCT=1
SET SRFLD=""
WRITE !!,?15,"Missing Information:"
FOR
SET SRFLD=$ORDER(SRX(SRFLD))
if SRFLD=""
QUIT
if $Y+5>IOSL
DO PAGE
if SRSOUT
QUIT
WRITE !,$JUSTIFY(SRCT_". ",20),SRX(SRFLD)
SET SRCT=SRCT+1
LINE IF 'SRSOUT
WRITE !
FOR I=1:1:80
WRITE "-"
+1 QUIT
SCHED ; get appointment status from Scheduling
+1 NEW SRENC,SRVSIT,SRX
SET SRSCHED="<NONE>"
SET SRVSIT=$PIECE(SR(0),"^",15)
if 'SRVSIT
QUIT
+2 SET SRENC=$ORDER(^SCE("AVSIT",SRVSIT,0))
if 'SRENC
QUIT
+3 SET DA=SRENC
SET DIC=409.68
SET DR=".12"
SET DIQ="SRX"
SET DIQ(0)="E"
DO EN^DIQ1
KILL DA,DIC,DIQ,DR
+4 IF SRX(409.68,SRENC,.12,"E")="INPATIENT APPOINTMENT"
SET SRX(409.68,SRENC,.12,"E")="INPATIENT APPT"
+5 SET X=SRX(409.68,SRENC,.12,"E")
IF X'=""
SET SRSCHED=X
+6 QUIT
CASE ; print case info
+1 if $Y+9>IOSL
DO PAGE
if SRSOUT
QUIT
DO DEM
DO PROC
DO SCHED
+2 WRITE !,SRSDATE,?22,SRSNM,?44,SRSSN_" ("_SRAGE_")",?66,$SELECT(SRSTATUS=1:"FILED",SRSTATUS=4:"NOT FILED",1:"UNCERTAIN")
+3 WRITE !,SRTN,?22,$EXTRACT(SRSSNM,1,20),?66,$EXTRACT(SRSCHED,1,14),!
if (SRFLG=3)&SRNON
WRITE "NON-O.R."
WRITE ?22,SRPROC(1)
if $DATA(SRPROC(2))
WRITE !,?22,SRPROC(2)
if $DATA(SRPROC(3))
WRITE !,?22,SRPROC(3)
+4 QUIT
DEM ; get patient demographic information
+1 SET SR(0)=^SRF(SRTN,0)
SET DFN=$PIECE(SR(0),"^")
DO DEM^VADPT
SET SRSNM=VADM(1)
SET SRSSN=VA("PID")
SET Y=SRSDT
XECUTE ^DD("DD")
SET SRSDATE=Y
SET X1=$EXTRACT(SRSDT,1,7)
SET X2=$PIECE(VADM(3),"^")
SET SRAGE=$EXTRACT(X1,1,3)-$EXTRACT(X2,1,3)-($EXTRACT(X1,4,7)<$EXTRACT(X2,4,7))
+2 IF $LENGTH(SRSNM)>20
SET SRSNM=$PIECE(VADM(1),",")_","_$EXTRACT($PIECE(VADM(1),",",2))_"."
+3 QUIT
PROC ; get principal procedure
+1 KILL SRPROC
SET X=$PIECE(^SRF(SRTN,"OP"),"^")
IF $LENGTH(X)<56
SET SRPROC(1)=X
+2 IF $LENGTH(X)>55
SET K=1
FOR
Begin DoDot:1
+3 FOR I=0:1:54
SET J=55-I
SET Y=$EXTRACT(X,J)
IF Y=" "
SET SRPROC(K)=$EXTRACT(X,1,J-1)
SET X=$EXTRACT(X,J+1,$LENGTH(X))
SET K=K+1
QUIT
End DoDot:1
IF $LENGTH(X)<56
SET SRPROC(K)=X
QUIT
+4 QUIT
PAGE IF $EXTRACT(IOST)="P"!SRHDR
GOTO HDR
+1 WRITE !
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
SET SRSOUT=1
QUIT
HDR ; print heading
+1 IF $DATA(ZTQUEUED)
DO ^SROSTOP
IF SRHALT
SET SRSOUT=1
QUIT
+2 if $Y
WRITE @IOF
if $EXTRACT(IOST)="P"
WRITE !,?(80-$LENGTH(SRINST)\2),SRINST
WRITE !,?(80-$LENGTH(SRRPT)\2),SRRPT,?70,$JUSTIFY("PAGE "_SRPAGE,9),!,?(80-$LENGTH(SRTITLE)\2),SRTITLE,!,?(80-$LENGTH(SRFRTO)\2),SRFRTO
if $EXTRACT(IOST)="P"
WRITE !,?(80-$LENGTH(SRPRINT)\2),SRPRINT
+3 WRITE !!,"DATE OF "_$SELECT(SRFLG=1:"OPERATION",SRFLG=2:"PROCEDURE",1:"OP/PROCEDURE"),?22,"PATIENT NAME",?44,"PATIENT ID (AGE)",?66,"FILING STATUS",!,"CASE #",?22,"SPECIALTY",?66,"SCHED STATUS",!,?22,"PRINCIPAL PROCEDURE"
+4 SET SRHDR=0
SET SRPAGE=SRPAGE+1
WRITE !
FOR I=1:1:80
WRITE "="
+5 QUIT
