- SROCD1 ;BIR/ADM - CREATE CODING RECORD ;05/16/05
- ;;3.0; Surgery ;**142,152**;24 Jun 93
- N SR,SRD,SRDX,SRDICN,SRIEN,SRM,SRMOD,SRN,SRO,SROTH,SRP,SRPD,SRX,SRY,X,Y
- I $P($G(^SRO(136,SRTN,0)),"^")'=SRTN D NEW
- S SR(0)=$G(^SRF(SRTN,0))
- S $P(^SRO(136,SRTN,0),"^",2)=$P($G(^SRF(SRTN,"OP")),"^",2)
- S $P(^SRO(136,SRTN,0),"^",3)=$P($G(^SRF(SRTN,34)),"^",2)
- SC S $P(^SRO(136,SRTN,0),"^",4)=$P(SR(0),"^",16)
- AO S $P(^SRO(136,SRTN,0),"^",5)=$P(SR(0),"^",17)
- IR S $P(^SRO(136,SRTN,0),"^",6)=$P(SR(0),"^",18)
- EC S $P(^SRO(136,SRTN,0),"^",7)=$P(SR(0),"^",19)
- MST S $P(^SRO(136,SRTN,0),"^",8)=$P(SR(0),"^",22)
- HNC S $P(^SRO(136,SRTN,0),"^",9)=$P(SR(0),"^",23)
- CV S $P(^SRO(136,SRTN,0),"^",10)=$P(SR(0),"^",24)
- PRJ S $P(^SRO(136,SRTN,0),"^",11)=$P(SR(0),"^",25)
- PMOD S SRM=0 F S SRM=$O(^SRF(SRTN,"OPMOD",SRM)) Q:'SRM D
- .S SRMOD=$P(^SRF(SRTN,"OPMOD",SRM,0),"^")
- .S SRY(136.01,"+1,"_SRTN_",",.01)=SRMOD D UPDATE^DIE("","SRY") K SRY
- PDX S SRD=0 F S SRD=$O(^SRF(SRTN,"PADX",SRD)) Q:'SRD D
- .S SRX=$P(^SRF(SRTN,"PADX",SRD,0),"^")
- .I SRX=0 S SRDX=$P($G(^SRF(SRTN,34)),"^",2)
- .E S SRDX=$P($G(^SRF(SRTN,15,SRX,0)),"^",3)
- .I SRDX S SRY(136.02,"+1,"_SRTN_",",.01)=SRDX D UPDATE^DIE("","SRY") K SRY
- POTH S SRO=0 F S SRO=$O(^SRF(SRTN,13,SRO)) Q:'SRO D
- .S SROTH=$P($G(^SRF(SRTN,13,SRO,2)),"^") Q:'SROTH S SRDICN=1
- .K DD,DO,DIC S DIC="^SRO(136,SRTN,3,",DIC(0)="L",X=SROTH D FILE^DICN K DA,DD,DIC,DO,DR S SRIEN=+Y I SRIEN'>0 Q
- .S SRM=0 F S SRM=$O(^SRF(SRTN,13,SRO,"MOD",SRM)) Q:'SRM D
- ..S SRMOD=$P(^SRF(SRTN,13,SRO,"MOD",SRM,0),"^")
- ..S SRY(136.31,"+1,"_SRIEN_","_SRTN_",",.01)=SRMOD D UPDATE^DIE("","SRY") K SRY
- .S SRD=0 F S SRD=$O(^SRF(SRTN,13,SRO,"OADX",SRD)) Q:'SRD D
- ..S SRX=$P(^SRF(SRTN,13,SRO,"OADX",SRD,0),"^")
- ..I SRX=0 S SRDX=$P($G(^SRF(SRTN,34)),"^",2)
- ..E S SRDX=$P($G(^SRF(SRTN,15,SRX,0)),"^",3)
- ..I SRDX S SRY(136.32,"+1,"_SRIEN_","_SRTN_",",.01)=SRDX D UPDATE^DIE("","SRY") K SRY
- ; other diagnoses
- S SRP=0 F S SRP=$O(^SRF(SRTN,15,SRP)) Q:'SRP D
- .S SRPD=$P(^SRF(SRTN,15,SRP,0),"^",3) Q:'SRPD S SRIS=$G(^SRF(SRTN,15,SRP,2))
- .S SRY(136.04,"+1,"_SRTN_",",.01)=SRPD,SRY(136.04,"+1,"_SRTN_",",.02)=$P(SRIS,"^")
- .S SRY(136.04,"+1,"_SRTN_",",.03)=$P(SRIS,"^",2),SRY(136.04,"+1,"_SRTN_",",.04)=$P(SRIS,"^",3)
- .S SRY(136.04,"+1,"_SRTN_",",.05)=$P(SRIS,"^",4),SRY(136.04,"+1,"_SRTN_",",.06)=$P(SRIS,"^",5)
- .S SRY(136.04,"+1,"_SRTN_",",.07)=$P(SRIS,"^",6),SRY(136.04,"+1,"_SRTN_",",.08)=$P(SRIS,"^",7)
- .S SRY(136.04,"+1,"_SRTN_",",.09)=$P(SRIS,"^",8)
- .D UPDATE^DIE("","SRY") K SRIS,SRY
- Q
- NEW K DA,DIC,DD,DO,DINUM S (DINUM,X)=SRTN,DIC="^SRO(136,",DIC(0)="L" D FILE^DICN K DD,DO,DIC,DINUM
- Q
- CHNG() ; check for changes to data
- N SRI,SRJ,SRK,SRS,SRCHNG S SRCHNG=0
- M ^TMP("SRED2",$J,SRTN)=^SRO(136,SRTN)
- I $G(^TMP("SRED1",$J,SRTN,0))'=$G(^TMP("SRED2",$J,SRTN,0)) Q 1
- D COMP
- Q SRCHNG
- COMP S SRI=0 F S SRI=$O(^TMP("SRED1",$J,SRTN,1,SRI)) Q:'SRI!SRCHNG I $G(^TMP("SRED1",$J,SRTN,1,SRI,0))'=$G(^TMP("SRED2",$J,SRTN,1,SRI,0)) S SRCHNG=1 Q
- S SRI=0 F S SRI=$O(^TMP("SRED1",$J,SRTN,2,SRI)) Q:'SRI!SRCHNG I $G(^TMP("SRED1",$J,SRTN,2,SRI,0))'=$G(^TMP("SRED2",$J,SRTN,2,SRI,0)) S SRCHNG=1 Q
- S SRI=0 F S SRI=$O(^TMP("SRED1",$J,SRTN,3,SRI)) Q:'SRI!SRCHNG D Q:SRCHNG
- .I $G(^TMP("SRED1",$J,SRTN,3,SRI,0))'=$G(^TMP("SRED2",$J,SRTN,3,SRI,0)) S SRCHNG=1 Q
- .F SRS=1,2 S SRK=0 F S SRK=$O(^TMP("SRED1",$J,SRTN,3,SRI,SRS,SRK)) Q:'SRK!SRCHNG I $G(^TMP("SRED1",$J,SRTN,3,SRI,SRS,SRK,0))'=$G(^TMP("SRED2",$J,SRTN,3,SRI,SRS,SRK,0)) S SRCHNG=1 Q
- S SRI=0 F S SRI=$O(^TMP("SRED1",$J,SRTN,4,SRI)) Q:'SRI!SRCHNG I $G(^TMP("SRED1",$J,SRTN,4,SRI,0))'=$G(^TMP("SRED2",$J,SRTN,4,SRI,0)) S SRCHNG=1 Q
- S SRI=0 F S SRI=$O(^TMP("SRED2",$J,SRTN,1,SRI)) Q:'SRI!SRCHNG I $G(^TMP("SRED2",$J,SRTN,1,SRI,0))'=$G(^TMP("SRED1",$J,SRTN,1,SRI,0)) S SRCHNG=1 Q
- S SRI=0 F S SRI=$O(^TMP("SRED2",$J,SRTN,2,SRI)) Q:'SRI!SRCHNG I $G(^TMP("SRED2",$J,SRTN,2,SRI,0))'=$G(^TMP("SRED1",$J,SRTN,2,SRI,0)) S SRCHNG=1 Q
- S SRI=0 F S SRI=$O(^TMP("SRED2",$J,SRTN,3,SRI)) Q:'SRI!SRCHNG D Q:SRCHNG
- .I $G(^TMP("SRED2",$J,SRTN,3,SRI,0))'=$G(^TMP("SRED1",$J,SRTN,3,SRI,0)) S SRCHNG=1 Q
- .F SRS=1,2 S SRK=0 F S SRK=$O(^TMP("SRED2",$J,SRTN,3,SRI,SRS,SRK)) Q:'SRK!SRCHNG I $G(^TMP("SRED2",$J,SRTN,3,SRI,SRS,SRK,0))'=$G(^TMP("SRED1",$J,SRTN,3,SRI,SRS,SRK,0)) S SRCHNG=1 Q
- S SRI=0 F S SRI=$O(^TMP("SRED2",$J,SRTN,4,SRI)) Q:'SRI!SRCHNG I $G(^TMP("SRED2",$J,SRTN,4,SRI,0))'=$G(^TMP("SRED1",$J,SRTN,4,SRI,0)) S SRCHNG=1 Q
- K ^TMP("SRED1",$J),^TMP("SRED2",$J)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROCD1 4495 printed Feb 19, 2025@00:09:05 Page 2
- SROCD1 ;BIR/ADM - CREATE CODING RECORD ;05/16/05
- +1 ;;3.0; Surgery ;**142,152**;24 Jun 93
- +2 NEW SR,SRD,SRDX,SRDICN,SRIEN,SRM,SRMOD,SRN,SRO,SROTH,SRP,SRPD,SRX,SRY,X,Y
- +3 IF $PIECE($GET(^SRO(136,SRTN,0)),"^")'=SRTN
- DO NEW
- +4 SET SR(0)=$GET(^SRF(SRTN,0))
- +5 SET $PIECE(^SRO(136,SRTN,0),"^",2)=$PIECE($GET(^SRF(SRTN,"OP")),"^",2)
- +6 SET $PIECE(^SRO(136,SRTN,0),"^",3)=$PIECE($GET(^SRF(SRTN,34)),"^",2)
- SC SET $PIECE(^SRO(136,SRTN,0),"^",4)=$PIECE(SR(0),"^",16)
- AO SET $PIECE(^SRO(136,SRTN,0),"^",5)=$PIECE(SR(0),"^",17)
- IR SET $PIECE(^SRO(136,SRTN,0),"^",6)=$PIECE(SR(0),"^",18)
- EC SET $PIECE(^SRO(136,SRTN,0),"^",7)=$PIECE(SR(0),"^",19)
- MST SET $PIECE(^SRO(136,SRTN,0),"^",8)=$PIECE(SR(0),"^",22)
- HNC SET $PIECE(^SRO(136,SRTN,0),"^",9)=$PIECE(SR(0),"^",23)
- CV SET $PIECE(^SRO(136,SRTN,0),"^",10)=$PIECE(SR(0),"^",24)
- PRJ SET $PIECE(^SRO(136,SRTN,0),"^",11)=$PIECE(SR(0),"^",25)
- PMOD SET SRM=0
- FOR
- SET SRM=$ORDER(^SRF(SRTN,"OPMOD",SRM))
- if 'SRM
- QUIT
- Begin DoDot:1
- +1 SET SRMOD=$PIECE(^SRF(SRTN,"OPMOD",SRM,0),"^")
- +2 SET SRY(136.01,"+1,"_SRTN_",",.01)=SRMOD
- DO UPDATE^DIE("","SRY")
- KILL SRY
- End DoDot:1
- PDX SET SRD=0
- FOR
- SET SRD=$ORDER(^SRF(SRTN,"PADX",SRD))
- if 'SRD
- QUIT
- Begin DoDot:1
- +1 SET SRX=$PIECE(^SRF(SRTN,"PADX",SRD,0),"^")
- +2 IF SRX=0
- SET SRDX=$PIECE($GET(^SRF(SRTN,34)),"^",2)
- +3 IF '$TEST
- SET SRDX=$PIECE($GET(^SRF(SRTN,15,SRX,0)),"^",3)
- +4 IF SRDX
- SET SRY(136.02,"+1,"_SRTN_",",.01)=SRDX
- DO UPDATE^DIE("","SRY")
- KILL SRY
- End DoDot:1
- POTH SET SRO=0
- FOR
- SET SRO=$ORDER(^SRF(SRTN,13,SRO))
- if 'SRO
- QUIT
- Begin DoDot:1
- +1 SET SROTH=$PIECE($GET(^SRF(SRTN,13,SRO,2)),"^")
- if 'SROTH
- QUIT
- SET SRDICN=1
- +2 KILL DD,DO,DIC
- SET DIC="^SRO(136,SRTN,3,"
- SET DIC(0)="L"
- SET X=SROTH
- DO FILE^DICN
- KILL DA,DD,DIC,DO,DR
- SET SRIEN=+Y
- IF SRIEN'>0
- QUIT
- +3 SET SRM=0
- FOR
- SET SRM=$ORDER(^SRF(SRTN,13,SRO,"MOD",SRM))
- if 'SRM
- QUIT
- Begin DoDot:2
- +4 SET SRMOD=$PIECE(^SRF(SRTN,13,SRO,"MOD",SRM,0),"^")
- +5 SET SRY(136.31,"+1,"_SRIEN_","_SRTN_",",.01)=SRMOD
- DO UPDATE^DIE("","SRY")
- KILL SRY
- End DoDot:2
- +6 SET SRD=0
- FOR
- SET SRD=$ORDER(^SRF(SRTN,13,SRO,"OADX",SRD))
- if 'SRD
- QUIT
- Begin DoDot:2
- +7 SET SRX=$PIECE(^SRF(SRTN,13,SRO,"OADX",SRD,0),"^")
- +8 IF SRX=0
- SET SRDX=$PIECE($GET(^SRF(SRTN,34)),"^",2)
- +9 IF '$TEST
- SET SRDX=$PIECE($GET(^SRF(SRTN,15,SRX,0)),"^",3)
- +10 IF SRDX
- SET SRY(136.32,"+1,"_SRIEN_","_SRTN_",",.01)=SRDX
- DO UPDATE^DIE("","SRY")
- KILL SRY
- End DoDot:2
- End DoDot:1
- +11 ; other diagnoses
- +12 SET SRP=0
- FOR
- SET SRP=$ORDER(^SRF(SRTN,15,SRP))
- if 'SRP
- QUIT
- Begin DoDot:1
- +13 SET SRPD=$PIECE(^SRF(SRTN,15,SRP,0),"^",3)
- if 'SRPD
- QUIT
- SET SRIS=$GET(^SRF(SRTN,15,SRP,2))
- +14 SET SRY(136.04,"+1,"_SRTN_",",.01)=SRPD
- SET SRY(136.04,"+1,"_SRTN_",",.02)=$PIECE(SRIS,"^")
- +15 SET SRY(136.04,"+1,"_SRTN_",",.03)=$PIECE(SRIS,"^",2)
- SET SRY(136.04,"+1,"_SRTN_",",.04)=$PIECE(SRIS,"^",3)
- +16 SET SRY(136.04,"+1,"_SRTN_",",.05)=$PIECE(SRIS,"^",4)
- SET SRY(136.04,"+1,"_SRTN_",",.06)=$PIECE(SRIS,"^",5)
- +17 SET SRY(136.04,"+1,"_SRTN_",",.07)=$PIECE(SRIS,"^",6)
- SET SRY(136.04,"+1,"_SRTN_",",.08)=$PIECE(SRIS,"^",7)
- +18 SET SRY(136.04,"+1,"_SRTN_",",.09)=$PIECE(SRIS,"^",8)
- +19 DO UPDATE^DIE("","SRY")
- KILL SRIS,SRY
- End DoDot:1
- +20 QUIT
- NEW KILL DA,DIC,DD,DO,DINUM
- SET (DINUM,X)=SRTN
- SET DIC="^SRO(136,"
- SET DIC(0)="L"
- DO FILE^DICN
- KILL DD,DO,DIC,DINUM
- +1 QUIT
- CHNG() ; check for changes to data
- +1 NEW SRI,SRJ,SRK,SRS,SRCHNG
- SET SRCHNG=0
- +2 MERGE ^TMP("SRED2",$JOB,SRTN)=^SRO(136,SRTN)
- +3 IF $GET(^TMP("SRED1",$JOB,SRTN,0))'=$GET(^TMP("SRED2",$JOB,SRTN,0))
- QUIT 1
- +4 DO COMP
- +5 QUIT SRCHNG
- COMP SET SRI=0
- FOR
- SET SRI=$ORDER(^TMP("SRED1",$JOB,SRTN,1,SRI))
- if 'SRI!SRCHNG
- QUIT
- IF $GET(^TMP("SRED1",$JOB,SRTN,1,SRI,0))'=$GET(^TMP("SRED2",$JOB,SRTN,1,SRI,0))
- SET SRCHNG=1
- QUIT
- +1 SET SRI=0
- FOR
- SET SRI=$ORDER(^TMP("SRED1",$JOB,SRTN,2,SRI))
- if 'SRI!SRCHNG
- QUIT
- IF $GET(^TMP("SRED1",$JOB,SRTN,2,SRI,0))'=$GET(^TMP("SRED2",$JOB,SRTN,2,SRI,0))
- SET SRCHNG=1
- QUIT
- +2 SET SRI=0
- FOR
- SET SRI=$ORDER(^TMP("SRED1",$JOB,SRTN,3,SRI))
- if 'SRI!SRCHNG
- QUIT
- Begin DoDot:1
- +3 IF $GET(^TMP("SRED1",$JOB,SRTN,3,SRI,0))'=$GET(^TMP("SRED2",$JOB,SRTN,3,SRI,0))
- SET SRCHNG=1
- QUIT
- +4 FOR SRS=1,2
- SET SRK=0
- FOR
- SET SRK=$ORDER(^TMP("SRED1",$JOB,SRTN,3,SRI,SRS,SRK))
- if 'SRK!SRCHNG
- QUIT
- IF $GET(^TMP("SRED1",$JOB,SRTN,3,SRI,SRS,SRK,0))'=$GET(^TMP("SRED2",$JOB,SRTN,3,SRI,SRS,SRK,0))
- SET SRCHNG=1
- QUIT
- End DoDot:1
- if SRCHNG
- QUIT
- +5 SET SRI=0
- FOR
- SET SRI=$ORDER(^TMP("SRED1",$JOB,SRTN,4,SRI))
- if 'SRI!SRCHNG
- QUIT
- IF $GET(^TMP("SRED1",$JOB,SRTN,4,SRI,0))'=$GET(^TMP("SRED2",$JOB,SRTN,4,SRI,0))
- SET SRCHNG=1
- QUIT
- +6 SET SRI=0
- FOR
- SET SRI=$ORDER(^TMP("SRED2",$JOB,SRTN,1,SRI))
- if 'SRI!SRCHNG
- QUIT
- IF $GET(^TMP("SRED2",$JOB,SRTN,1,SRI,0))'=$GET(^TMP("SRED1",$JOB,SRTN,1,SRI,0))
- SET SRCHNG=1
- QUIT
- +7 SET SRI=0
- FOR
- SET SRI=$ORDER(^TMP("SRED2",$JOB,SRTN,2,SRI))
- if 'SRI!SRCHNG
- QUIT
- IF $GET(^TMP("SRED2",$JOB,SRTN,2,SRI,0))'=$GET(^TMP("SRED1",$JOB,SRTN,2,SRI,0))
- SET SRCHNG=1
- QUIT
- +8 SET SRI=0
- FOR
- SET SRI=$ORDER(^TMP("SRED2",$JOB,SRTN,3,SRI))
- if 'SRI!SRCHNG
- QUIT
- Begin DoDot:1
- +9 IF $GET(^TMP("SRED2",$JOB,SRTN,3,SRI,0))'=$GET(^TMP("SRED1",$JOB,SRTN,3,SRI,0))
- SET SRCHNG=1
- QUIT
- +10 FOR SRS=1,2
- SET SRK=0
- FOR
- SET SRK=$ORDER(^TMP("SRED2",$JOB,SRTN,3,SRI,SRS,SRK))
- if 'SRK!SRCHNG
- QUIT
- IF $GET(^TMP("SRED2",$JOB,SRTN,3,SRI,SRS,SRK,0))'=$GET(^TMP("SRED1",$JOB,SRTN,3,SRI,SRS,SRK,0))
- SET SRCHNG=1
- QUIT
- End DoDot:1
- if SRCHNG
- QUIT
- +11 SET SRI=0
- FOR
- SET SRI=$ORDER(^TMP("SRED2",$JOB,SRTN,4,SRI))
- if 'SRI!SRCHNG
- QUIT
- IF $GET(^TMP("SRED2",$JOB,SRTN,4,SRI,0))'=$GET(^TMP("SRED1",$JOB,SRTN,4,SRI,0))
- SET SRCHNG=1
- QUIT
- +12 KILL ^TMP("SRED1",$JOB),^TMP("SRED2",$JOB)
- +13 QUIT