- SROPCE0A ;BIR/ADM - PCE FILING STATUS REPORT, LONG FORM ;03/17/05
- ;;3.0; Surgery ;**58,62,69,77,50,86,88,127,142**;24 Jun 93
- ;
- ; Reference to ^ECC(723 supported by DBIA #205
- ;
- S (SRFCPT,SRQCPT,SRFICD,SRQICD,SRUCPT,SRUICD)=0
- 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+10>IOSL PAGE Q:SRSOUT W !,?28,"CPT",?36,"ICD",!,?20,"CASES",?27,"CODES",?35,"CODES",!,?13,"FILED: ",$J(CNT(1),5),?27,$J(SRFCPT,5),?35,$J(SRFICD,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,"-----",!,?13,"TOTAL: ",$J(CNT(6),5),?27,$J(SRFCPT+SRQCPT+SRUCPT,5),?35,$J(SRFICD+SRQICD+SRUICD,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 !
- 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 Diagnosis Code: "_SRDX(SRI)
- .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 S SRJ=1,X=$P($G(^SRO(136,SRTN,0)),"^",3) I X D
- .S SRDX(1)=$$ICDDX^ICDCODE(X,$P($G(^SRF(SRTN,0)),"^",9)),SRDX(1)=$P(SRDX(1),"^",2)_" "_$P(SRDX(1),"^",4),SRJ=SRJ+1
- .S:SRSTATUS=1 SRFICD=SRFICD+1 S:SRSTATUS=2 SRQICD=SRQICD+1 S:SRSTATUS=3 SRUICD=SRUICD+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 SRDX(SRJ)=$$ICDDX^ICDCODE(X,$P($G(^SRF(SRTN,0)),"^",9)),SRDX(SRJ)=$P(SRDX(SRJ),"^",2)_" "_$P(SRDX(SRJ),"^",4),SRJ=SRJ+1
- .S:SRSTATUS=1 SRFICD=SRFICD+1 S:SRSTATUS=2 SRQICD=SRQICD+1 S:SRSTATUS=3 SRUICD=SRUICD+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
- 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**;24 Jun 93
- +2 ;
- +3 ; Reference to ^ECC(723 supported by DBIA #205
- +4 ;
- +5 SET (SRFCPT,SRQCPT,SRFICD,SRQICD,SRUCPT,SRUICD)=0
- +6 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
- +7 IF 'SRSOUT
- DO TOTAL
- +8 QUIT
- TOTAL IF $Y+10>IOSL
- DO PAGE
- IF SRSOUT
- QUIT
- WRITE !,?28,"CPT",?36,"ICD",!,?20,"CASES",?27,"CODES",?35,"CODES",!,?13,"FILED: ",$JUSTIFY(CNT(1),5),?27,$JUSTIFY(SRFCPT,5),?35,$JUSTIFY(SRFICD,5)
- +1 WRITE !,?9,"NOT FILED: "_$JUSTIFY(CNT(4),5)
- 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,"-----",?27,"-----",?35,"-----",!,?13,"TOTAL: ",$JUSTIFY(CNT(6),5),?27,$JUSTIFY(SRFCPT+SRQCPT+SRUCPT,5),?35,$JUSTIFY(SRFICD+SRQICD+SRUICD,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)
- 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 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
- +6 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 Diagnosis Code: "_SRDX(SRI)
- +7 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
- SET SRJ=1
- SET X=$PIECE($GET(^SRO(136,SRTN,0)),"^",3)
- IF X
- Begin DoDot:1
- +2 SET SRDX(1)=$$ICDDX^ICDCODE(X,$PIECE($GET(^SRF(SRTN,0)),"^",9))
- SET SRDX(1)=$PIECE(SRDX(1),"^",2)_" "_$PIECE(SRDX(1),"^",4)
- SET SRJ=SRJ+1
- +3 IF SRSTATUS=1
- SET SRFICD=SRFICD+1
- IF SRSTATUS=2
- SET SRQICD=SRQICD+1
- IF SRSTATUS=3
- SET SRUICD=SRUICD+1
- End DoDot:1
- +4 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
- +5 SET SRDX(SRJ)=$$ICDDX^ICDCODE(X,$PIECE($GET(^SRF(SRTN,0)),"^",9))
- SET SRDX(SRJ)=$PIECE(SRDX(SRJ),"^",2)_" "_$PIECE(SRDX(SRJ),"^",4)
- SET SRJ=SRJ+1
- +6 IF SRSTATUS=1
- SET SRFICD=SRFICD+1
- IF SRSTATUS=2
- SET SRQICD=SRQICD+1
- IF SRSTATUS=3
- SET SRUICD=SRUICD+1
- End DoDot:1
- +7 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
