- SROVER3 ;BIR/ADM - Case Coding and Verification ;07/26/07
- ;;3.0;Surgery;**86,88,127,119,152,159,177**;24 Jun 93;Build 89
- ;;
- ; Reference to CL^SDCO21 supported by DBIA #406
- ;;
- S SROVER=1,SRAO(1)=26,SRAO(2)=27,SRAO(3)="",SRAO(4)=$S(SRNON:33,1:34),SRAO(5)=66,SRAO(6)="",SRAO(7)=32,SRAO(8)=32.5,SRMSG="NO Assoc. DX ENTERED"
- ASK W ! K DIR S DIR("A")="Select Information to Edit: ",DIR(0)="FOA",DIR("?",1)="Enter the number corresponding to the information you want to update. You may"
- S DIR("?",2)="enter 'ALL' to update all the information displayed on this screen, or a",DIR("?")="range of numbers separated by a ':' to update more than one item." D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q
- I X="" S SREDIT=1 Q
- S:$E(X)="a" X="A" I '$D(SRAO(X)),(X'?.N1":".N),($E(X)'="A") D HELP Q:SRSOUT G ASK
- I $E(X)="A" S X="1:8"
- I X?.N1":".N S Y=$E(X),Z=$P(X,":",2) I Y<1!(Z>8)!(Y>Z) D HELP Q:SRSOUT G ASK
- D HDR^SROVER2 I X?.N1":".N D RANGE Q
- S EMILY=X D ONE Q
- Q
- HELP W !!,"Enter the number corresponding to the information you want to update. You may",!,"enter 'ALL' to update all the information displayed on this screen, or a"
- W !,"range of numbers separated by a ':' to update more than one item."
- Q
- PRESS W ! K DIR S DIR("A")="Press RETURN to continue ",DIR(0)="FOA" D ^DIR K DIR
- Q
- RANGE ; range of numbers
- S SHEMP=$P(X,":"),CURLEY=$P(X,":",2) F EMILY=SHEMP:1:CURLEY Q:SRSOUT W ! D ONE
- Q
- ONE ; edit one item
- I EMILY=3 D POTH Q
- I EMILY=6 D DOTH Q
- W ! K DR,DIE,DA S DIE=130,DA=SRTN,DR=SRAO(EMILY)_"T" D ^DIE K DR,DIE I $D(Y) S SRSOUT=1
- I EMILY=4&($$SCEC()) D ASK^SROPCE1 K SRCL
- I EMILY=2 D CASDX^SROADX
- Q
- POTH W !,"Other Procedures:",!
- N SRSHT K SRSEL S CNT=1,OTH=0 F S OTH=$O(^SRF(SRTN,13,OTH)) Q:'OTH!(SRSOUT) D
- .S OTHER=$P(^SRF(SRTN,13,OTH,0),U),X=$P($G(^SRF(SRTN,13,OTH,2)),U),CPT="NOT ENTERED",CPT1=""
- .I X S CPT1=X,Y=$$CPT^ICPTCOD(X,$P($G(^SRF(SRTN,0)),"^",9)),SRCPT=$P(Y,U,2),SRSHT=$P(Y,U,3),Y=SRCPT,SRDA=OTH D SSOTH^SROCPT S SRCPT=Y,CPT=SRCPT_" "_SRSHT
- .W !,CNT_". "_OTHER
- .W !,?5,"CPT Code: "_CPT
- .S SRSEL(CNT)=OTH_"^"_OTHER_"^CPT Code: "_CPT_"^"_CPT1
- .D OTHADXD^SROADX1
- .S CNT=CNT+1
- W !,CNT_". Enter NEW Other Procedure",! K DIR S DIR("A")="Enter selection",DIR(0)="NO^1:"_CNT D ^DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q
- Q:'Y S SRDA=Y W !! I SRDA<CNT D G PH
- .D HDR^SROVER2
- .W !,"Other Procedures:",!
- .W !,SRDA,"."
- .W ?3,$P(SRSEL(SRDA),U,2),!,?5,$P(SRSEL(SRDA),U,3)
- .S OTH=$P(SRSEL(SRDA),U) K SRDES S CPT1=$P(SRSEL(SRDA),U,4),X=$$CPTD^ICPTCOD(CPT1,"SRDES",,$P($G(^SRF(SRTN,0)),"^",9)) I $O(SRDES(0)) F I=1:1:X W !,?5,SRDES(I)
- .K DA,DIE,DIR,DR W ! S DA=$P(SRSEL(SRDA),U),DA(1)=SRTN,DIE="^SRF(SRTN,13,",DR=".01;3" D ^DIE D:$D(DA) COTHADX^SROADX K DA,DIE,DR Q:$D(Y) D PRESS
- K DIR S DIR("A")="Enter new OTHER PROCEDURE",DIR(0)="130.16,.01" D ^DIR K DIR S SRNEW=Y I $D(DTOUT)!$D(DUOUT)!(Y="") G PH
- K DD,DO S DIC="^SRF(SRTN,13,",X=SRNEW,DIC(0)="L",DIC("P")=$P(^DD(130,.42,0),U,2) D FILE^DICN K DIC,DD,DO I +Y<0 Q
- K DA,DIE,DIR,DR S DA=+Y,DA(1)=SRTN,DIE="^SRF(SRTN,13,",DR="3" D ^DIE K DA,DIE,DR Q:$D(Y) S SRDA=CNT,OTHER=SRNEW D COTHADX^SROADX D PRESS
- PH D HDR^SROVER2 D POTH
- Q
- DOTH W !,"Other Postop Diagnosis:",!
- N SCEC,ENVARR S SCEC=$$SCEC()
- K SRSEL S CNT=1,OTH=0 F S OTH=$O(^SRF(SRTN,15,OTH)) Q:'OTH!(SRSOUT) D
- .S OTHER=$P(^SRF(SRTN,15,OTH,0),U),X=$P($G(^SRF(SRTN,15,OTH,0)),U,3),SRDIAG="NOT ENTERED"
- .I X S Y=$$ICD^SROICD(SRTN,X),SRNUM=$P(Y,U,2),SRDES=$P(Y,U,4),SRDIAG=SRNUM_" "_SRDES
- .W !,CNT_". "_OTHER,!,?5,"ICD"_$$ICD910^SROICD(SRTN)_" Code: "_SRDIAG S SRSEL(CNT)=OTH_"^"_OTHER_"^ICD Code: "_SRDIAG
- .D:SCEC
- ..D GETS^DIQ(130.18,OTH_","_SRTN_",","4:11","E","ENVARR")
- ..I $D(ENVARR(130.18,OTH_","_SRTN_",",4,"E")) D
- ...N SRCOLSPN S SRCOLSPN=13 W !
- ...I $D(SRCL(3)) W ?SRCOLSPN,"SC:",$E(ENVARR(130.18,OTH_","_SRTN_",",4,"E")) S SRCOLSPN=SRCOLSPN+8
- ...I $D(SRCL(7)) W ?SRCOLSPN,"CV:",$E(ENVARR(130.18,OTH_","_SRTN_",",10,"E")) S SRCOLSPN=SRCOLSPN+8
- ...I $D(SRCL(1)) W ?SRCOLSPN,"AO:",$E(ENVARR(130.18,OTH_","_SRTN_",",5,"E")) S SRCOLSPN=SRCOLSPN+8
- ...I $D(SRCL(2)) W ?SRCOLSPN,"IR:",$E(ENVARR(130.18,OTH_","_SRTN_",",6,"E")) S SRCOLSPN=SRCOLSPN+8
- ...I $D(SRCL(4)) W ?SRCOLSPN,"SWAC:",$E(ENVARR(130.18,OTH_","_SRTN_",",9,"E")) S SRCOLSPN=SRCOLSPN+8
- ...I $D(SRCL(8)) W ?SRCOLSPN,"SHAD:",$E(ENVARR(130.18,OTH_","_SRTN_",",11,"E")) S SRCOLSPN=SRCOLSPN+8
- ...I $D(SRCL(5)) W ?SRCOLSPN,"MST:",$E(ENVARR(130.18,OTH_","_SRTN_",",7,"E")) S SRCOLSPN=SRCOLSPN+8
- ...I $D(SRCL(6)) W ?SRCOLSPN,"H&N:",$E(ENVARR(130.18,OTH_","_SRTN_",",8,"E")) S SRCOLSPN=SRCOLSPN+8
- .S CNT=CNT+1
- W !,CNT_". Enter NEW Other Postop Diagnosis",! K DIR S DIR("A")="Enter selection",DIR(0)="NO^1:"_CNT D ^DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q
- Q:'Y S SRDA=Y W !! I SRDA<CNT D G DH
- .W ?3,$P(SRSEL(SRDA),U,2),!,?5,$P(SRSEL(SRDA),U,3)
- .N SRCVET K DA,DIE,DIR S DA=$P(SRSEL(SRDA),U),DA(1)=SRTN,DIE="^SRF(SRTN,15,",DR=".01T;3T;"
- .S SRCVET=$P($G(^SRF(SRTN,15,DA,2)),"^",7) S SRCVET=$S(SRCVET=0:"NO",1:"YES")
- .S:$D(SRCL(3)) DR=DR_"4T;" S:$D(SRCL(7)) DR=DR_"10T//"_SRCVET_";" S:$D(SRCL(1)) DR=DR_"5T;" S:$D(SRCL(2)) DR=DR_"6T;" S:$D(SRCL(4)) DR=DR_"9T;" S:$D(SRCL(5)) DR=DR_"7T;" S:$D(SRCL(6)) DR=DR_"8T;" S:$D(SRCL(8)) DR=DR_"11T;"
- .D ^DIE K DA,DIE,DIR,DR
- K DIR,SRCL S DIR("A")="Enter new Other Postop Diagnosis",DIR(0)="130.18,.01" D ^DIR K DIR S SRNEW=Y I $D(DTOUT)!$D(DUOUT)!(Y="") G DH
- S DIR("A")="Planned Other ICD Diagnosis Code",DIR(0)="130.18,3" D ^DIR K DIR S SRCODE=$P(Y,U) I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q
- S:'$D(DA(1)) DA(1)=SRTN
- S SRCODE=Y K DD,DO S DIC="^SRF(SRTN,15,",X=SRNEW,DIC(0)="L",DIC("DR")="3////"_$P(SRCODE,U),DIC("P")=$P(^DD(130,.74,0),U,2) D FILE^DICN K DA,DD,DIC,DO,DR
- DH D HDR^SROVER2 D DOTH
- Q
- SCEC() N SRSDATE,DFN,SCEC S SRSDATE=$S($D(SRTN):$P(^SRF(SRTN,0),U,9),1:DT)
- S DFN=$P(^SRF(SRTN,0),U) D CL^SDCO21(DFN,SRSDATE,,.SRCL)
- S SCEC=$S($D(SRCL):1,1:0)
- Q SCEC
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROVER3 5917 printed Feb 19, 2025@00:13:05 Page 2
- SROVER3 ;BIR/ADM - Case Coding and Verification ;07/26/07
- +1 ;;3.0;Surgery;**86,88,127,119,152,159,177**;24 Jun 93;Build 89
- +2 ;;
- +3 ; Reference to CL^SDCO21 supported by DBIA #406
- +4 ;;
- +5 SET SROVER=1
- SET SRAO(1)=26
- SET SRAO(2)=27
- SET SRAO(3)=""
- SET SRAO(4)=$SELECT(SRNON:33,1:34)
- SET SRAO(5)=66
- SET SRAO(6)=""
- SET SRAO(7)=32
- SET SRAO(8)=32.5
- SET SRMSG="NO Assoc. DX ENTERED"
- ASK WRITE !
- KILL DIR
- SET DIR("A")="Select Information to Edit: "
- SET DIR(0)="FOA"
- SET DIR("?",1)="Enter the number corresponding to the information you want to update. You may"
- +1 SET DIR("?",2)="enter 'ALL' to update all the information displayed on this screen, or a"
- SET DIR("?")="range of numbers separated by a ':' to update more than one item."
- DO ^DIR
- KILL DIR
- IF $DATA(DTOUT)!$DATA(DUOUT)
- SET SRSOUT=1
- QUIT
- +2 IF X=""
- SET SREDIT=1
- QUIT
- +3 if $EXTRACT(X)="a"
- SET X="A"
- IF '$DATA(SRAO(X))
- IF (X'?.N1":".N)
- IF ($EXTRACT(X)'="A")
- DO HELP
- if SRSOUT
- QUIT
- GOTO ASK
- +4 IF $EXTRACT(X)="A"
- SET X="1:8"
- +5 IF X?.N1":".N
- SET Y=$EXTRACT(X)
- SET Z=$PIECE(X,":",2)
- IF Y<1!(Z>8)!(Y>Z)
- DO HELP
- if SRSOUT
- QUIT
- GOTO ASK
- +6 DO HDR^SROVER2
- IF X?.N1":".N
- DO RANGE
- QUIT
- +7 SET EMILY=X
- DO ONE
- QUIT
- +8 QUIT
- HELP WRITE !!,"Enter the number corresponding to the information you want to update. You may",!,"enter 'ALL' to update all the information displayed on this screen, or a"
- +1 WRITE !,"range of numbers separated by a ':' to update more than one item."
- +2 QUIT
- PRESS WRITE !
- KILL DIR
- SET DIR("A")="Press RETURN to continue "
- SET DIR(0)="FOA"
- DO ^DIR
- KILL DIR
- +1 QUIT
- RANGE ; range of numbers
- +1 SET SHEMP=$PIECE(X,":")
- SET CURLEY=$PIECE(X,":",2)
- FOR EMILY=SHEMP:1:CURLEY
- if SRSOUT
- QUIT
- WRITE !
- DO ONE
- +2 QUIT
- ONE ; edit one item
- +1 IF EMILY=3
- DO POTH
- QUIT
- +2 IF EMILY=6
- DO DOTH
- QUIT
- +3 WRITE !
- KILL DR,DIE,DA
- SET DIE=130
- SET DA=SRTN
- SET DR=SRAO(EMILY)_"T"
- DO ^DIE
- KILL DR,DIE
- IF $DATA(Y)
- SET SRSOUT=1
- +4 IF EMILY=4&($$SCEC())
- DO ASK^SROPCE1
- KILL SRCL
- +5 IF EMILY=2
- DO CASDX^SROADX
- +6 QUIT
- POTH WRITE !,"Other Procedures:",!
- +1 NEW SRSHT
- KILL SRSEL
- SET CNT=1
- SET OTH=0
- FOR
- SET OTH=$ORDER(^SRF(SRTN,13,OTH))
- if 'OTH!(SRSOUT)
- QUIT
- Begin DoDot:1
- +2 SET OTHER=$PIECE(^SRF(SRTN,13,OTH,0),U)
- SET X=$PIECE($GET(^SRF(SRTN,13,OTH,2)),U)
- SET CPT="NOT ENTERED"
- SET CPT1=""
- +3 IF X
- SET CPT1=X
- SET Y=$$CPT^ICPTCOD(X,$PIECE($GET(^SRF(SRTN,0)),"^",9))
- SET SRCPT=$PIECE(Y,U,2)
- SET SRSHT=$PIECE(Y,U,3)
- SET Y=SRCPT
- SET SRDA=OTH
- DO SSOTH^SROCPT
- SET SRCPT=Y
- SET CPT=SRCPT_" "_SRSHT
- +4 WRITE !,CNT_". "_OTHER
- +5 WRITE !,?5,"CPT Code: "_CPT
- +6 SET SRSEL(CNT)=OTH_"^"_OTHER_"^CPT Code: "_CPT_"^"_CPT1
- +7 DO OTHADXD^SROADX1
- +8 SET CNT=CNT+1
- End DoDot:1
- +9 WRITE !,CNT_". Enter NEW Other Procedure",!
- KILL DIR
- SET DIR("A")="Enter selection"
- SET DIR(0)="NO^1:"_CNT
- DO ^DIR
- IF $DATA(DTOUT)!$DATA(DUOUT)
- SET SRSOUT=1
- QUIT
- +10 if 'Y
- QUIT
- SET SRDA=Y
- WRITE !!
- IF SRDA<CNT
- Begin DoDot:1
- +11 DO HDR^SROVER2
- +12 WRITE !,"Other Procedures:",!
- +13 WRITE !,SRDA,"."
- +14 WRITE ?3,$PIECE(SRSEL(SRDA),U,2),!,?5,$PIECE(SRSEL(SRDA),U,3)
- +15 SET OTH=$PIECE(SRSEL(SRDA),U)
- KILL SRDES
- SET CPT1=$PIECE(SRSEL(SRDA),U,4)
- SET X=$$CPTD^ICPTCOD(CPT1,"SRDES",,$PIECE($GET(^SRF(SRTN,0)),"^",9))
- IF $ORDER(SRDES(0))
- FOR I=1:1:X
- WRITE !,?5,SRDES(I)
- +16 KILL DA,DIE,DIR,DR
- WRITE !
- SET DA=$PIECE(SRSEL(SRDA),U)
- SET DA(1)=SRTN
- SET DIE="^SRF(SRTN,13,"
- SET DR=".01;3"
- DO ^DIE
- if $DATA(DA)
- DO COTHADX^SROADX
- KILL DA,DIE,DR
- if $DATA(Y)
- QUIT
- DO PRESS
- End DoDot:1
- GOTO PH
- +17 KILL DIR
- SET DIR("A")="Enter new OTHER PROCEDURE"
- SET DIR(0)="130.16,.01"
- DO ^DIR
- KILL DIR
- SET SRNEW=Y
- IF $DATA(DTOUT)!$DATA(DUOUT)!(Y="")
- GOTO PH
- +18 KILL DD,DO
- SET DIC="^SRF(SRTN,13,"
- SET X=SRNEW
- SET DIC(0)="L"
- SET DIC("P")=$PIECE(^DD(130,.42,0),U,2)
- DO FILE^DICN
- KILL DIC,DD,DO
- IF +Y<0
- QUIT
- +19 KILL DA,DIE,DIR,DR
- SET DA=+Y
- SET DA(1)=SRTN
- SET DIE="^SRF(SRTN,13,"
- SET DR="3"
- DO ^DIE
- KILL DA,DIE,DR
- if $DATA(Y)
- QUIT
- SET SRDA=CNT
- SET OTHER=SRNEW
- DO COTHADX^SROADX
- DO PRESS
- PH DO HDR^SROVER2
- DO POTH
- +1 QUIT
- DOTH WRITE !,"Other Postop Diagnosis:",!
- +1 NEW SCEC,ENVARR
- SET SCEC=$$SCEC()
- +2 KILL SRSEL
- SET CNT=1
- SET OTH=0
- FOR
- SET OTH=$ORDER(^SRF(SRTN,15,OTH))
- if 'OTH!(SRSOUT)
- QUIT
- Begin DoDot:1
- +3 SET OTHER=$PIECE(^SRF(SRTN,15,OTH,0),U)
- SET X=$PIECE($GET(^SRF(SRTN,15,OTH,0)),U,3)
- SET SRDIAG="NOT ENTERED"
- +4 IF X
- SET Y=$$ICD^SROICD(SRTN,X)
- SET SRNUM=$PIECE(Y,U,2)
- SET SRDES=$PIECE(Y,U,4)
- SET SRDIAG=SRNUM_" "_SRDES
- +5 WRITE !,CNT_". "_OTHER,!,?5,"ICD"_$$ICD910^SROICD(SRTN)_" Code: "_SRDIAG
- SET SRSEL(CNT)=OTH_"^"_OTHER_"^ICD Code: "_SRDIAG
- +6 if SCEC
- Begin DoDot:2
- +7 DO GETS^DIQ(130.18,OTH_","_SRTN_",","4:11","E","ENVARR")
- +8 IF $DATA(ENVARR(130.18,OTH_","_SRTN_",",4,"E"))
- Begin DoDot:3
- +9 NEW SRCOLSPN
- SET SRCOLSPN=13
- WRITE !
- +10 IF $DATA(SRCL(3))
- WRITE ?SRCOLSPN,"SC:",$EXTRACT(ENVARR(130.18,OTH_","_SRTN_",",4,"E"))
- SET SRCOLSPN=SRCOLSPN+8
- +11 IF $DATA(SRCL(7))
- WRITE ?SRCOLSPN,"CV:",$EXTRACT(ENVARR(130.18,OTH_","_SRTN_",",10,"E"))
- SET SRCOLSPN=SRCOLSPN+8
- +12 IF $DATA(SRCL(1))
- WRITE ?SRCOLSPN,"AO:",$EXTRACT(ENVARR(130.18,OTH_","_SRTN_",",5,"E"))
- SET SRCOLSPN=SRCOLSPN+8
- +13 IF $DATA(SRCL(2))
- WRITE ?SRCOLSPN,"IR:",$EXTRACT(ENVARR(130.18,OTH_","_SRTN_",",6,"E"))
- SET SRCOLSPN=SRCOLSPN+8
- +14 IF $DATA(SRCL(4))
- WRITE ?SRCOLSPN,"SWAC:",$EXTRACT(ENVARR(130.18,OTH_","_SRTN_",",9,"E"))
- SET SRCOLSPN=SRCOLSPN+8
- +15 IF $DATA(SRCL(8))
- WRITE ?SRCOLSPN,"SHAD:",$EXTRACT(ENVARR(130.18,OTH_","_SRTN_",",11,"E"))
- SET SRCOLSPN=SRCOLSPN+8
- +16 IF $DATA(SRCL(5))
- WRITE ?SRCOLSPN,"MST:",$EXTRACT(ENVARR(130.18,OTH_","_SRTN_",",7,"E"))
- SET SRCOLSPN=SRCOLSPN+8
- +17 IF $DATA(SRCL(6))
- WRITE ?SRCOLSPN,"H&N:",$EXTRACT(ENVARR(130.18,OTH_","_SRTN_",",8,"E"))
- SET SRCOLSPN=SRCOLSPN+8
- End DoDot:3
- End DoDot:2
- +18 SET CNT=CNT+1
- End DoDot:1
- +19 WRITE !,CNT_". Enter NEW Other Postop Diagnosis",!
- KILL DIR
- SET DIR("A")="Enter selection"
- SET DIR(0)="NO^1:"_CNT
- DO ^DIR
- IF $DATA(DTOUT)!$DATA(DUOUT)
- SET SRSOUT=1
- QUIT
- +20 if 'Y
- QUIT
- SET SRDA=Y
- WRITE !!
- IF SRDA<CNT
- Begin DoDot:1
- +21 WRITE ?3,$PIECE(SRSEL(SRDA),U,2),!,?5,$PIECE(SRSEL(SRDA),U,3)
- +22 NEW SRCVET
- KILL DA,DIE,DIR
- SET DA=$PIECE(SRSEL(SRDA),U)
- SET DA(1)=SRTN
- SET DIE="^SRF(SRTN,15,"
- SET DR=".01T;3T;"
- +23 SET SRCVET=$PIECE($GET(^SRF(SRTN,15,DA,2)),"^",7)
- SET SRCVET=$SELECT(SRCVET=0:"NO",1:"YES")
- +24 if $DATA(SRCL(3))
- SET DR=DR_"4T;"
- if $DATA(SRCL(7))
- SET DR=DR_"10T//"_SRCVET_";"
- if $DATA(SRCL(1))
- SET DR=DR_"5T;"
- if $DATA(SRCL(2))
- SET DR=DR_"6T;"
- if $DATA(SRCL(4))
- SET DR=DR_"9T;"
- if $DATA(SRCL(5))
- SET DR=DR_"7T;"
- if $DATA(SRCL(6))
- SET DR=DR_"8T;"
- if $DATA(SRCL(8))
- SET DR=DR_"11T;"
- +25 DO ^DIE
- KILL DA,DIE,DIR,DR
- End DoDot:1
- GOTO DH
- +26 KILL DIR,SRCL
- SET DIR("A")="Enter new Other Postop Diagnosis"
- SET DIR(0)="130.18,.01"
- DO ^DIR
- KILL DIR
- SET SRNEW=Y
- IF $DATA(DTOUT)!$DATA(DUOUT)!(Y="")
- GOTO DH
- +27 SET DIR("A")="Planned Other ICD Diagnosis Code"
- SET DIR(0)="130.18,3"
- DO ^DIR
- KILL DIR
- SET SRCODE=$PIECE(Y,U)
- IF $DATA(DTOUT)!$DATA(DUOUT)
- SET SRSOUT=1
- QUIT
- +28 if '$DATA(DA(1))
- SET DA(1)=SRTN
- +29 SET SRCODE=Y
- KILL DD,DO
- SET DIC="^SRF(SRTN,15,"
- SET X=SRNEW
- SET DIC(0)="L"
- SET DIC("DR")="3////"_$PIECE(SRCODE,U)
- SET DIC("P")=$PIECE(^DD(130,.74,0),U,2)
- DO FILE^DICN
- KILL DA,DD,DIC,DO,DR
- DH DO HDR^SROVER2
- DO DOTH
- +1 QUIT
- SCEC() NEW SRSDATE,DFN,SCEC
- SET SRSDATE=$SELECT($DATA(SRTN):$PIECE(^SRF(SRTN,0),U,9),1:DT)
- +1 SET DFN=$PIECE(^SRF(SRTN,0),U)
- DO CL^SDCO21(DFN,SRSDATE,,.SRCL)
- +2 SET SCEC=$SELECT($DATA(SRCL):1,1:0)
- +3 QUIT SCEC