SROPCE0A ;BIR/ADM - PCE FILING STATUS REPORT, LONG FORM ;03/17/05
;;3.0;Surgery;**58,62,69,77,50,86,88,127,142,177**;24 Jun 93;Build 89
;
; Reference to ^ECC(723 supported by DBIA #205
;
S (SRFCPT,SRQCPT,SRFICD,SRQICD,SRUCPT,SRUICD)=0
N SRIMPDT,ICD
S (SRFICD(9),SRFICD(10),SRQICD(9),SRQICD(10),SRUICD(9),SRUICD(10))=0
D HDR
F S SRSDT=$O(^SRF("AC",SRSDT)) Q:'SRSDT!(SRSDT>SRSEDT)!SRSOUT D
. S SRTN=0 F S SRTN=$O(^SRF("AC",SRSDT,SRTN)) Q:'SRTN D
.. I $D(^SRF(SRTN,0)),$$DIV^SROUTL0(SRTN),$P($G(^SRF(SRTN,30)),"^")="" D UTIL Q:SRSOUT
D:'SRSOUT TOTAL
Q
TOTAL D ICDCHK D:$Y+10>IOSL PAGE Q:SRSOUT
W !,?28,"CPT",?36,$S(ICD=9:"ICD9",ICD=10:"ICD10",ICD=910:"ICD9 ICD10",1:"")
W !,?20,"CASES",?27,"CODES",?35,"CODES" W:ICD=910 ?43,"CODES"
W !,?13,"FILED: ",$J(CNT(1),5),?27,$J(SRFCPT,5) W:ICD=910 ?35,$J(SRFICD(9),5),?43,$J(SRFICD(10),5) W:ICD=9 ?35,$J(SRFICD(9),5) W:ICD=10 ?35,$J(SRFICD(10),5)
W !,?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,"-----",?27,"-----",?35,"-----" W:ICD=910 ?43,"-----"
W !,?13,"TOTAL: ",$J(CNT(6),5),?27,$J(SRFCPT+SRQCPT+SRUCPT,5)
W:ICD=9!(ICD=10) ?35,$J(SRFICD(ICD)+SRQICD(ICD)+SRUICD(ICD),5) W:ICD=910 ?35,$J(SRFICD(9)+SRQICD(9)+SRUICD(9),5),?43,$J(SRFICD(10)+SRQICD(10)+SRUICD(10),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)) Q:'$P($G(^SRF(SRTN,.2)),"^",12)
I SRFLG=2!(SRFLG=3&SRNON) Q:'$P($G(^SRF(SRTN,"NON")),"^",5)
Q:SRFLG=2&('SRNON) Q:SRFLG=1&(SRNON)
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:IOM W "-"
Q
CASE ; print case info
D:$Y+9>IOSL PAGE Q:SRSOUT D DEM,SCHED^SROPCE0B
W !,SRSDATE,?22,SRSNM,?49,SRPROV,?71,SRSSNM,?113,$S(SRSTATUS=1:"FILED",SRSTATUS=4:"NOT FILED",1:"UNCERTAIN")
W !,SRTN,?22,SRSSN_" ("_SRAGE_")",?49,SRATT,?71,SRDIAG(1),?113,$E(SRSCHED,1,17),!
W:(SRFLG=3)&SRNON "NON-OR" W ?22,SRPROC(1) W:$D(SRDIAG(2)) ?71,SRDIAG(2) W:$D(SRPROC(2)) !,?22,SRPROC(2) W:$D(SRPROC(3)) !,?22,SRPROC(3) W !
; JAS - 6/10/13 - PATCH 177 - Modified to print 2nd line for Diagnosis description, if available
I "1,2,3"[SRSTATUS F SRI=1:1 Q:'$D(SRCPT(SRI))&'$D(SRDX(SRI)) D:$Y+4>IOSL PAGE Q:SRSOUT W ! D W:$D(SRDX(SRI)) ?71,"ICD"_$$ICD910^SROICD(SRTN)_" Diagnosis Code: "_SRDX(SRI) W:$G(SRDX(SRI,2))'="" !,?83,"DX Cont.: "_SRDX(SRI,2)
.I $D(SRCPT(SRI)) S SRCPT(SRI)=$S($D(SRDX(SRI)):$E(SRCPT(SRI),1,68),1:SRCPT(SRI)) W ?1,SRCPT(SRI)
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)>25 S X=SRSNM,SRSNM=$P(X,",")_","_$E($P(X,",",2))_"."
PROC ; get principal procedure and other case information
K SRPROC S X=$P(^SRF(SRTN,"OP"),"^") I $L(X)<60 S SRPROC(1)=X
I $L(X)>59 S K=1 F D I $L(X)<60 S SRPROC(K)=X Q
.F I=0:1:58 S J=59-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
K SRDIAG S X=$S(SRNON:$P($G(^SRF(SRTN,33)),"^",2),1:$P($G(^SRF(SRTN,34)),"^")) I $L(X)<40 S SRDIAG(1)=X
I $L(X)>39 S K=1 F D I $L(X)<40 S SRDIAG(K)=X Q
.F I=0:1:38 S J=39-I,Y=$E(X,J) I Y=" " S SRDIAG(K)=$E(X,1,J-1),X=$E(X,J+1,$L(X)) S K=K+1 Q
I SRDIAG(1)="" S SRDIAG(1)="NOT ENTERED"
I SRNON S X=$G(^SRF(SRTN,"NON")) S SRPROV=$S($P(X,"^",6):$P(^VA(200,$P(X,"^",6),0),"^"),1:"NOT ENTERED"),SRATT=$S($P(X,"^",7):$P(^VA(200,$P(X,"^",7),0),"^"),1:"NOT ENTERED")
I 'SRNON S X=$G(^SRF(SRTN,.1)) S SRPROV=$S($P(X,"^",4):$P(^VA(200,$P(X,"^",4),0),"^"),1:"NOT ENTERED"),SRATT=$S($P(X,"^",13):$P(^VA(200,$P(X,"^",13),0),"^"),1:"NOT ENTERED")
I $L(SRPROV)>20 S X=SRPROV,SRPROV=$P(X,",")_","_$E($P(X,",",2))_"."
I $L(SRATT)>20 S X=SRATT,SRATT=$P(X,",")_","_$E($P(X,",",2))_"."
Q:"1,2,3"'[SRSTATUS
CPT ; get CPT codes
N SRICPT K SRCPT S SRJ=1,X=$P($G(^SRO(136,SRTN,0)),"^",2) I X D
.S SRICPT=$$CPT^ICPTCOD(X,$P($G(^SRF(SRTN,0)),"^",9)),SRCPT(1)="CPT Code: "_$P(SRICPT,"^",2)_" "_$P(SRICPT,"^",3),SRJ=SRJ+1
.S:SRSTATUS=1 SRFCPT=SRFCPT+1 S:SRSTATUS=2 SRQCPT=SRQCPT+1 S:SRSTATUS=3 SRUCPT=SRUCPT+1
.I X,$O(^SRO(136,SRTN,1,0)) D
..N SRI,SRX,SRY,SRZ S SRX=" Modifiers: -"
..S SRI=0 F S SRI=$O(^SRO(136,SRTN,1,SRI)) Q:'SRI D
...S SRZ=$P(^SRO(136,SRTN,1,SRI,0),"^"),SRY=$$MOD^ICPTMOD(SRZ,"I",$P($G(^SRF(SRTN,0)),"^",9)),SRX=SRX_$P(SRY,"^",2)_" "_$P(SRY,"^",3)
...S SRCPT(SRJ)=SRX,SRJ=SRJ+1,SRX=" -"
S SROP=0 F S SROP=$O(^SRO(136,SRTN,3,SROP)) Q:'SROP S X=$P($G(^SRO(136,SRTN,3,SROP,0)),"^") I X D
.S SRICPT=$$CPT^ICPTCOD(X,$P($G(^SRF(SRTN,0)),"^",9)),SRCPT(SRJ)="CPT Code: "_$P(SRICPT,"^",2)_" "_$P(SRICPT,"^",3),SRJ=SRJ+1
.I $O(^SRO(136,SRTN,3,SROP,1,0)) D
..N SRI,SRX,SRY,SRZ S SRX=" Modifiers: -"
..S SRI=0 F S SRI=$O(^SRO(136,SRTN,3,SROP,1,SRI)) Q:'SRI D
...S SRZ=$P(^SRO(136,SRTN,3,SROP,1,SRI,0),"^"),SRY=$$MOD^ICPTMOD(SRZ,"I",$P($G(^SRF(SRTN,0)),"^",9)),SRX=SRX_$P(SRY,"^",2)_" "_$P(SRY,"^",3)
...S SRCPT(SRJ)=SRX,SRJ=SRJ+1,SRX=" -"
.S:SRSTATUS=1 SRFCPT=SRFCPT+1 S:SRSTATUS=2 SRQCPT=SRQCPT+1 S:SRSTATUS=3 SRUCPT=SRUCPT+1
DX ; get diagnosis and ICD codes
K SRDX,SRSYS,SRSY S SRJ=1,X=$P($G(^SRO(136,SRTN,0)),"^",3) I X D
.S SRSYS=$$ICDSYS^SROICD($P(^SRF(SRTN,0),"^",9)),SRSY=$S(SRSYS="10D":10,1:9)
.; JAS - 6/10/13 - PATCH 177 - Created additional array variable to contain remainder of ICD-10 short description
.N SRPARSE S SRDX(1)=$$ICD^SROICD(SRTN,X),SRPARSE(1)=$P(SRDX(1),"^",4) D PR^SROICDL(.SRPARSE,31)
.I +SRPARSE>1 S SRDX(1,2)=SRPARSE(2)_" "_$G(SRPARSE(3))
.S SRDX(1)=$P(SRDX(1),"^",2)_" "_SRPARSE(1),SRJ=SRJ+1 K SRPARSE
.; End 177
.S:SRSTATUS=1 SRFICD=$G(SRFICD)+1,SRFICD(SRSY)=$G(SRFICD(SRSY))+1 S:SRSTATUS=2 SRQICD=$G(SRQICD)+1,SRQICD(SRSY)=$G(SRQICD(SRSY))+1 S:SRSTATUS=3 SRUICD=$G(SRUICD)+1,SRUICD(SRSY)=$G(SRUICD(SRSY))+1
S SRPODX=0 F S SRPODX=$O(^SRO(136,SRTN,4,SRPODX)) Q:'SRPODX S X=$P(^SRO(136,SRTN,4,SRPODX,0),"^") I X D
.S SRSYS=$$ICDSYS^SROICD($P(^SRF(SRTN,0),"^",9)),SRSY=$S(SRSYS="10D":10,1:9)
.; JAS - 6/10/13 - PATCH 177 - Created additional array variable to contain remainder of ICD-10 short description
.N SRPARSE S SRDX(SRJ)=$$ICD^SROICD(SRTN,X),SRPARSE(1)=$P(SRDX(SRJ),"^",4) D PR^SROICDL(.SRPARSE,31)
.I +SRPARSE>1 S SRDX(SRJ,2)=SRPARSE(2)_" "_$G(SRPARSE(3))
.S SRDX(SRJ)=$P(SRDX(SRJ),"^",2)_" "_SRPARSE(1),SRJ=SRJ+1 K SRPARSE
.; End 177
.S:SRSTATUS=1 SRFICD=$G(SRFICD)+1,SRFICD(SRSY)=$G(SRFICD(SRSY))+1 S:SRSTATUS=2 SRQICD=$G(SRQICD)+1,SRQICD(SRSY)=$G(SRQICD(SRSY))+1 S:SRSTATUS=3 SRUICD=$G(SRUICD)+1,SRUICD(SRSY)=$G(SRUICD(SRSY))+1
. ;
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" !,?(IOM-$L(SRINST)\2),SRINST W !,?(IOM-$L(SRRPT)\2),SRRPT,?(IOM-10),$J("PAGE "_SRPAGE,9),!,?(IOM-$L(SRTITLE)\2),SRTITLE,!,?(IOM-$L(SRFRTO)\2),SRFRTO W:$E(IOST)="P" !,?(IOM-$L(SRPRINT)\2),SRPRINT
W !!,"DATE OF "_$S(SRFLG=1:"OPERATION",SRFLG=2:"PROCEDURE",1:"OP/PROCEDURE"),?22,"PATIENT NAME",?49,$S(SRFLG=1:"SURGEON",SRFLG=2:"PROVIDER",1:"SURGEON/PROVIDER"),?71,"SPECIALTY",?113,"PCE FILING STATUS"
W !,"CASE #",?22,"PATIENT ID (AGE)",?49,"ATTENDING",?71,"PRINCIPAL "_$S(SRFLG=1:"POST-OP ",1:"")_"DIAGNOSIS",?113,"SCHED STATUS",!,?22,"PRINCIPAL PROCEDURE"
S SRHDR=0,SRPAGE=SRPAGE+1 W ! F I=1:1:IOM W "="
Q
ICDCHK S SRIMPDT=$$IMPDATE^SROICD("10D")
S:SDATE<SRIMPDT&(EDATE<SRIMPDT) ICD=9 S:SDATE'<SRIMPDT&(EDATE'<SRIMPDT) ICD=10 S:SDATE<SRIMPDT&(EDATE'<SRIMPDT) ICD=910
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROPCE0A 8557 printed Apr 09, 2024@21:46:45 Page 2
SROPCE0A ;BIR/ADM - PCE FILING STATUS REPORT, LONG FORM ;03/17/05
+1 ;;3.0;Surgery;**58,62,69,77,50,86,88,127,142,177**;24 Jun 93;Build 89
+2 ;
+3 ; Reference to ^ECC(723 supported by DBIA #205
+4 ;
+5 SET (SRFCPT,SRQCPT,SRFICD,SRQICD,SRUCPT,SRUICD)=0
+6 NEW SRIMPDT,ICD
+7 SET (SRFICD(9),SRFICD(10),SRQICD(9),SRQICD(10),SRUICD(9),SRUICD(10))=0
+8 DO HDR
+9 FOR
SET SRSDT=$ORDER(^SRF("AC",SRSDT))
if 'SRSDT!(SRSDT>SRSEDT)!SRSOUT
QUIT
Begin DoDot:1
+10 SET SRTN=0
FOR
SET SRTN=$ORDER(^SRF("AC",SRSDT,SRTN))
if 'SRTN
QUIT
Begin DoDot:2
+11 IF $DATA(^SRF(SRTN,0))
IF $$DIV^SROUTL0(SRTN)
IF $PIECE($GET(^SRF(SRTN,30)),"^")=""
DO UTIL
if SRSOUT
QUIT
End DoDot:2
End DoDot:1
+12 if 'SRSOUT
DO TOTAL
+13 QUIT
TOTAL DO ICDCHK
if $Y+10>IOSL
DO PAGE
if SRSOUT
QUIT
+1 WRITE !,?28,"CPT",?36,$SELECT(ICD=9:"ICD9",ICD=10:"ICD10",ICD=910:"ICD9 ICD10",1:"")
+2 WRITE !,?20,"CASES",?27,"CODES",?35,"CODES"
if ICD=910
WRITE ?43,"CODES"
+3 WRITE !,?13,"FILED: ",$JUSTIFY(CNT(1),5),?27,$JUSTIFY(SRFCPT,5)
if ICD=910
WRITE ?35,$JUSTIFY(SRFICD(9),5),?43,$JUSTIFY(SRFICD(10),5)
if ICD=9
WRITE ?35,$JUSTIFY(SRFICD(9),5)
if ICD=10
WRITE ?35,$JUSTIFY(SRFICD(10),5)
+4 WRITE !,?9,"NOT FILED: "_$JUSTIFY(CNT(4),5)
FOR I=1:1:5
SET CNT(6)=CNT(6)+CNT(I)
+5 if CNT(5)
WRITE !,?9,"UNCERTAIN: "_$JUSTIFY(CNT(5),5)
WRITE !,?20,"-----",?27,"-----",?35,"-----"
if ICD=910
WRITE ?43,"-----"
+6 WRITE !,?13,"TOTAL: ",$JUSTIFY(CNT(6),5),?27,$JUSTIFY(SRFCPT+SRQCPT+SRUCPT,5)
+7 if ICD=9!(ICD=10)
WRITE ?35,$JUSTIFY(SRFICD(ICD)+SRQICD(ICD)+SRUICD(ICD),5)
if ICD=910
WRITE ?35,$JUSTIFY(SRFICD(9)+SRQICD(9)+SRUICD(9),5),?43,$JUSTIFY(SRFICD(10)+SRQICD(10)+SRUICD(10),5)
+8 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)
QUIT
if 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:IOM
WRITE "-"
+1 QUIT
CASE ; print case info
+1 if $Y+9>IOSL
DO PAGE
if SRSOUT
QUIT
DO DEM
DO SCHED^SROPCE0B
+2 WRITE !,SRSDATE,?22,SRSNM,?49,SRPROV,?71,SRSSNM,?113,$SELECT(SRSTATUS=1:"FILED",SRSTATUS=4:"NOT FILED",1:"UNCERTAIN")
+3 WRITE !,SRTN,?22,SRSSN_" ("_SRAGE_")",?49,SRATT,?71,SRDIAG(1),?113,$EXTRACT(SRSCHED,1,17),!
+4 if (SRFLG=3)&SRNON
WRITE "NON-OR"
WRITE ?22,SRPROC(1)
if $DATA(SRDIAG(2))
WRITE ?71,SRDIAG(2)
if $DATA(SRPROC(2))
WRITE !,?22,SRPROC(2)
if $DATA(SRPROC(3))
WRITE !,?22,SRPROC(3)
WRITE !
+5 ; JAS - 6/10/13 - PATCH 177 - Modified to print 2nd line for Diagnosis description, if available
+6 IF "1,2,3"[SRSTATUS
FOR SRI=1:1
if '$DATA(SRCPT(SRI))&'$DATA(SRDX(SRI))
QUIT
if $Y+4>IOSL
DO PAGE
if SRSOUT
QUIT
WRITE !
Begin DoDot:1
+7 IF $DATA(SRCPT(SRI))
SET SRCPT(SRI)=$SELECT($DATA(SRDX(SRI)):$EXTRACT(SRCPT(SRI),1,68),1:SRCPT(SRI))
WRITE ?1,SRCPT(SRI)
End DoDot:1
if $DATA(SRDX(SRI))
WRITE ?71,"ICD"_$$ICD910^SROICD(SRTN)_" Diagnosis Code: "_SRDX(SRI)
if $GET(SRDX(SRI,2))'=""
WRITE !,?83,"DX Cont.: "_SRDX(SRI,2)
+8 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)>25
SET X=SRSNM
SET SRSNM=$PIECE(X,",")_","_$EXTRACT($PIECE(X,",",2))_"."
PROC ; get principal procedure and other case information
+1 KILL SRPROC
SET X=$PIECE(^SRF(SRTN,"OP"),"^")
IF $LENGTH(X)<60
SET SRPROC(1)=X
+2 IF $LENGTH(X)>59
SET K=1
FOR
Begin DoDot:1
+3 FOR I=0:1:58
SET J=59-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)<60
SET SRPROC(K)=X
QUIT
+4 KILL SRDIAG
SET X=$SELECT(SRNON:$PIECE($GET(^SRF(SRTN,33)),"^",2),1:$PIECE($GET(^SRF(SRTN,34)),"^"))
IF $LENGTH(X)<40
SET SRDIAG(1)=X
+5 IF $LENGTH(X)>39
SET K=1
FOR
Begin DoDot:1
+6 FOR I=0:1:38
SET J=39-I
SET Y=$EXTRACT(X,J)
IF Y=" "
SET SRDIAG(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)<40
SET SRDIAG(K)=X
QUIT
+7 IF SRDIAG(1)=""
SET SRDIAG(1)="NOT ENTERED"
+8 IF SRNON
SET X=$GET(^SRF(SRTN,"NON"))
SET SRPROV=$SELECT($PIECE(X,"^",6):$PIECE(^VA(200,$PIECE(X,"^",6),0),"^"),1:"NOT ENTERED")
SET SRATT=$SELECT($PIECE(X,"^",7):$PIECE(^VA(200,$PIECE(X,"^",7),0),"^"),1:"NOT ENTERED")
+9 IF 'SRNON
SET X=$GET(^SRF(SRTN,.1))
SET SRPROV=$SELECT($PIECE(X,"^",4):$PIECE(^VA(200,$PIECE(X,"^",4),0),"^"),1:"NOT ENTERED")
SET SRATT=$SELECT($PIECE(X,"^",13):$PIECE(^VA(200,$PIECE(X,"^",13),0),"^"),1:"NOT ENTERED")
+10 IF $LENGTH(SRPROV)>20
SET X=SRPROV
SET SRPROV=$PIECE(X,",")_","_$EXTRACT($PIECE(X,",",2))_"."
+11 IF $LENGTH(SRATT)>20
SET X=SRATT
SET SRATT=$PIECE(X,",")_","_$EXTRACT($PIECE(X,",",2))_"."
+12 if "1,2,3"'[SRSTATUS
QUIT
CPT ; get CPT codes
+1 NEW SRICPT
KILL SRCPT
SET SRJ=1
SET X=$PIECE($GET(^SRO(136,SRTN,0)),"^",2)
IF X
Begin DoDot:1
+2 SET SRICPT=$$CPT^ICPTCOD(X,$PIECE($GET(^SRF(SRTN,0)),"^",9))
SET SRCPT(1)="CPT Code: "_$PIECE(SRICPT,"^",2)_" "_$PIECE(SRICPT,"^",3)
SET SRJ=SRJ+1
+3 if SRSTATUS=1
SET SRFCPT=SRFCPT+1
if SRSTATUS=2
SET SRQCPT=SRQCPT+1
if SRSTATUS=3
SET SRUCPT=SRUCPT+1
+4 IF X
IF $ORDER(^SRO(136,SRTN,1,0))
Begin DoDot:2
+5 NEW SRI,SRX,SRY,SRZ
SET SRX=" Modifiers: -"
+6 SET SRI=0
FOR
SET SRI=$ORDER(^SRO(136,SRTN,1,SRI))
if 'SRI
QUIT
Begin DoDot:3
+7 SET SRZ=$PIECE(^SRO(136,SRTN,1,SRI,0),"^")
SET SRY=$$MOD^ICPTMOD(SRZ,"I",$PIECE($GET(^SRF(SRTN,0)),"^",9))
SET SRX=SRX_$PIECE(SRY,"^",2)_" "_$PIECE(SRY,"^",3)
+8 SET SRCPT(SRJ)=SRX
SET SRJ=SRJ+1
SET SRX=" -"
End DoDot:3
End DoDot:2
End DoDot:1
+9 SET SROP=0
FOR
SET SROP=$ORDER(^SRO(136,SRTN,3,SROP))
if 'SROP
QUIT
SET X=$PIECE($GET(^SRO(136,SRTN,3,SROP,0)),"^")
IF X
Begin DoDot:1
+10 SET SRICPT=$$CPT^ICPTCOD(X,$PIECE($GET(^SRF(SRTN,0)),"^",9))
SET SRCPT(SRJ)="CPT Code: "_$PIECE(SRICPT,"^",2)_" "_$PIECE(SRICPT,"^",3)
SET SRJ=SRJ+1
+11 IF $ORDER(^SRO(136,SRTN,3,SROP,1,0))
Begin DoDot:2
+12 NEW SRI,SRX,SRY,SRZ
SET SRX=" Modifiers: -"
+13 SET SRI=0
FOR
SET SRI=$ORDER(^SRO(136,SRTN,3,SROP,1,SRI))
if 'SRI
QUIT
Begin DoDot:3
+14 SET SRZ=$PIECE(^SRO(136,SRTN,3,SROP,1,SRI,0),"^")
SET SRY=$$MOD^ICPTMOD(SRZ,"I",$PIECE($GET(^SRF(SRTN,0)),"^",9))
SET SRX=SRX_$PIECE(SRY,"^",2)_" "_$PIECE(SRY,"^",3)
+15 SET SRCPT(SRJ)=SRX
SET SRJ=SRJ+1
SET SRX=" -"
End DoDot:3
End DoDot:2
+16 if SRSTATUS=1
SET SRFCPT=SRFCPT+1
if SRSTATUS=2
SET SRQCPT=SRQCPT+1
if SRSTATUS=3
SET SRUCPT=SRUCPT+1
End DoDot:1
DX ; get diagnosis and ICD codes
+1 KILL SRDX,SRSYS,SRSY
SET SRJ=1
SET X=$PIECE($GET(^SRO(136,SRTN,0)),"^",3)
IF X
Begin DoDot:1
+2 SET SRSYS=$$ICDSYS^SROICD($PIECE(^SRF(SRTN,0),"^",9))
SET SRSY=$SELECT(SRSYS="10D":10,1:9)
+3 ; JAS - 6/10/13 - PATCH 177 - Created additional array variable to contain remainder of ICD-10 short description
+4 NEW SRPARSE
SET SRDX(1)=$$ICD^SROICD(SRTN,X)
SET SRPARSE(1)=$PIECE(SRDX(1),"^",4)
DO PR^SROICDL(.SRPARSE,31)
+5 IF +SRPARSE>1
SET SRDX(1,2)=SRPARSE(2)_" "_$GET(SRPARSE(3))
+6 SET SRDX(1)=$PIECE(SRDX(1),"^",2)_" "_SRPARSE(1)
SET SRJ=SRJ+1
KILL SRPARSE
+7 ; End 177
+8 if SRSTATUS=1
SET SRFICD=$GET(SRFICD)+1
SET SRFICD(SRSY)=$GET(SRFICD(SRSY))+1
if SRSTATUS=2
SET SRQICD=$GET(SRQICD)+1
SET SRQICD(SRSY)=$GET(SRQICD(SRSY))+1
if SRSTATUS=3
SET SRUICD=$GET(SRUICD)+1
SET SRUICD(SRSY)=$GET(SRUICD(SRSY))+1
End DoDot:1
+9 SET SRPODX=0
FOR
SET SRPODX=$ORDER(^SRO(136,SRTN,4,SRPODX))
if 'SRPODX
QUIT
SET X=$PIECE(^SRO(136,SRTN,4,SRPODX,0),"^")
IF X
Begin DoDot:1
+10 SET SRSYS=$$ICDSYS^SROICD($PIECE(^SRF(SRTN,0),"^",9))
SET SRSY=$SELECT(SRSYS="10D":10,1:9)
+11 ; JAS - 6/10/13 - PATCH 177 - Created additional array variable to contain remainder of ICD-10 short description
+12 NEW SRPARSE
SET SRDX(SRJ)=$$ICD^SROICD(SRTN,X)
SET SRPARSE(1)=$PIECE(SRDX(SRJ),"^",4)
DO PR^SROICDL(.SRPARSE,31)
+13 IF +SRPARSE>1
SET SRDX(SRJ,2)=SRPARSE(2)_" "_$GET(SRPARSE(3))
+14 SET SRDX(SRJ)=$PIECE(SRDX(SRJ),"^",2)_" "_SRPARSE(1)
SET SRJ=SRJ+1
KILL SRPARSE
+15 ; End 177
+16 if SRSTATUS=1
SET SRFICD=$GET(SRFICD)+1
SET SRFICD(SRSY)=$GET(SRFICD(SRSY))+1
if SRSTATUS=2
SET SRQICD=$GET(SRQICD)+1
SET SRQICD(SRSY)=$GET(SRQICD(SRSY))+1
if SRSTATUS=3
SET SRUICD=$GET(SRUICD)+1
SET SRUICD(SRSY)=$GET(SRUICD(SRSY))+1
+17 ;
End DoDot:1
+18 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 !,?(IOM-$LENGTH(SRINST)\2),SRINST
WRITE !,?(IOM-$LENGTH(SRRPT)\2),SRRPT,?(IOM-10),$JUSTIFY("PAGE "_SRPAGE,9),!,?(IOM-$LENGTH(SRTITLE)\2),SRTITLE,!,?(IOM-$LENGTH(SRFRTO)\2),SRFRTO
if $EXTRACT(IOST)="P"
WRITE !,?(IOM-$LENGTH(SRPRINT)\2),SRPRINT
+3 WRITE !!,"DATE OF "_$SELECT(SRFLG=1:"OPERATION",SRFLG=2:"PROCEDURE",1:"OP/PROCEDURE"),?22,"PATIENT NAME",?49,$SELECT(SRFLG=1:"SURGEON",SRFLG=2:"PROVIDER",1:"SURGEON/PROVIDER"),?71,"SPECIALTY",?113,"PCE FILING STATUS"
+4 WRITE !,"CASE #",?22,"PATIENT ID (AGE)",?49,"ATTENDING",?71,"PRINCIPAL "_$SELECT(SRFLG=1:"POST-OP ",1:"")_"DIAGNOSIS",?113,"SCHED STATUS",!,?22,"PRINCIPAL PROCEDURE"
+5 SET SRHDR=0
SET SRPAGE=SRPAGE+1
WRITE !
FOR I=1:1:IOM
WRITE "="
+6 QUIT
ICDCHK SET SRIMPDT=$$IMPDATE^SROICD("10D")
+1 if SDATE<SRIMPDT&(EDATE<SRIMPDT)
SET ICD=9
if SDATE'<SRIMPDT&(EDATE'<SRIMPDT)
SET ICD=10
if SDATE<SRIMPDT&(EDATE'<SRIMPDT)
SET ICD=910
+2 QUIT
