RORHIV03 ;HCIOFO/SG - CONVERSION OF THE FILE #158 ; 5/12/05 2:53pm
;;1.5;CLINICAL CASE REGISTRIES;;Feb 17, 2006
;
Q
;
;***** TRANSFERS THE CDC COMMENTS TO THE MULTIPLE #25
CDCOMM() ;
N CNT,I,IENS,RC,RORBUF,RORFDA,RORMSG,TMP
S (CNT,RC)=0
;--- Load the old comments (non-empty ones)
F I=3,2,1 D
. S TMP=$G(^IMR(158,IMRIEN,I+9))
. S:(TMP'="")!CNT RORBUF(I,0)=TMP,CNT=CNT+1
;--- Store the comments in the new word processing field
D:$D(RORBUF)>1
. S IENS=RORIEN_","
. S RORFDA(799.4,IENS,25)="RORBUF"
. D UPDATE^DIE(,"RORFDA",,"RORMSG")
. I $G(DIERR) D
. . S RC=$$DBS^RORERR("RORMSG",-9,,,799.4,IENS)
Q $S(RC<0:RC,1:0)
;
;***** TRANSFERS THE PATIENT'S DATA FROM FILE #158 TO FILE #799.4
;
; IMRIEN IEN of the IMMUNOLOGY CASE STUDY file record
; RORIEN IEN of the record of the ROR HIV RECORD file
;
; Return Values:
; <0 Error code
; 0 Ok
;
CNVPTDAT(IMRIEN,RORIEN) ;
N DA,DIK,RC,RORNODE,TMP
S RORNODE=""
;--- Check the parameters
I '$D(^IMR(158,IMRIEN,0)) D Q RC
. S RC=$$ERROR^RORERR(-88,,,,"IMRIEN",IMRIEN)
I '$D(^RORDATA(799.4,RORIEN,0)) D Q RC
. S RC=$$ERROR^RORERR(-88,,,,"RORIEN",RORIEN)
;---
S RORNODE=^RORDATA(799.4,RORIEN,0)
D COPY(0,"42>2,23>3")
D COPY(1,"7>4")
I $P(RORNODE,U,2)=4 D ; CLINICAL AIDS
. S $P(RORNODE,U,2)=1,TMP=$P(RORNODE,U,3)\1
. I TMP<1000000 S $P(RORNODE,U,3)="" Q
. S:'$E(TMP,4,5) $E(TMP,4,5)="01"
. S:'$E(TMP,6,7) $E(TMP,6,7)="01"
. S $P(RORNODE,U,3)=TMP
E S $P(RORNODE,U,2,3)=U
D STORE(0)
;---
D COPY(1,"6>1,34>5,9>9,10>10,11>11,12>12,13>13,14>14")
D COPY(2,"16>4")
D COPY(102,"8>7,23>8")
D COPY(110,"1>2,2>3")
D COPY(112,"5>6")
D STORE(9)
;---
D COPY(102,"19>5")
D COPY(110,"4>1,5>4")
D COPY(112,"7>2,8>3")
D STORE(11)
;---
D COPY(1,"16>2,17>3,18>4")
D COPY(2,"54>1")
D COPY(102,"10>7")
D COPY(110,"16>5")
D COPY(112,"6>6")
D STORE(12)
;---
D COPY(1,"26>3,20>6,28>7,29>8,30>9,31>10,32>12,21>13,22>14,23>15,24>17")
D TRANSL(1,19,5,"1,2,3","1,2,8")
D COPY(2,"21>1,23>2,53>4,55>18")
D COPY(102,"14>16")
D COPY(110,"3>11")
D STORE(14)
;---
D COPY(1,"35>1,36>9")
D COPY(2,"49>5"),TRANSL(2,50,7,"P,N,I,U","1,0,8,9")
D COPY(102,"20>11")
D COPY(108,"27>2,28>6,29>8,30>12")
D COPY(110,"17>3,18>4,19>13,20>14")
D STORE(16)
;---
D COPY(111,"10>1,11>2,12>3,13>4,14>5,1>6,2>7,3>8,4>9")
D STORE(18)
;---
D COPY(102,"21>1,22>3")
D COPY(108,"31>2")
D COPY(111,"5>4,6>5,7>6,8>7,9>8")
D STORE(20)
;---
D COPY(110,"6>1,7>2,8>4,9>5,10>6,11>7,12>8")
D COPY(112,"11>3")
D STORE(22)
;---
D TRANSL(110,13,1,"1,2,9","1,0,9")
D TRANSL(110,14,2,"1,2,9","1,0,9")
D TRANSL(110,15,3,"1,2,9","1,0,9")
D COPY(112,"1>4,2>5,3>6,4>7")
D STORE(23)
;---
S RC=$$INIDIAGS() Q:RC<0 RC
S RC=$$CDCOMM() Q:RC<0 RC
;--- Reindex the entry
S DIK="^RORDATA(799.4,",DA=RORIEN D IX1^DIK
Q 0
;
;***** COPY THE FIELD DATA
COPY(SRCN,PTLIST) ;
N DSTP,I,SRCP,TMP
S:'$D(RORNODE(SRCN)) RORNODE(SRCN)=$G(^IMR(158,IMRIEN,SRCN))
F I=1:1 S TMP=$P(PTLIST,",",I) Q:TMP="" D
. S SRCP=+$P(TMP,">"),DSTP=+$P(TMP,">",2)
. S TMP=$P(RORNODE(SRCN),U,SRCP)
. S:TMP'="" $P(RORNODE,U,DSTP)=TMP
Q
;
;***** TRANSFER INITIAL DIAGNOSES
INIDIAGS() ;
;;01^2;24^108;1
;;02^2;25^108;2
;;03^102;15^108;3
;;04^2;26^108;4
;;05^2;27^108;5
;;06^2;28^108;6
;;07^2;29^108;7
;;08^2;30^108;8
;;09^2;31^108;9
;;10^2;32^108;10
;;11^2;33^108;11
;;12^2;34^108;12
;;13^2;35^108;13
;;14^1;36^108;14
;;15^2;37^108;15
;;16^2;38^108;16
;;17^2;39^108;17
;;18^102;16^108;18
;;19^2;40^108;19
;;20^2;41^108;20
;;21^2;42^108;21
;;22^102;17^108;22
;;23^2;43^108;23
;;24^2;44^108;24
;;25^2;45^108;25
;;26^2;46^108;26
;
N BUF,DATE,DIAG,DIEN,I,IENS,RC,RORFDA,RORILST,RORMSG,TMP
K ^RORDATA(799.4,RORIEN,10) S RC=0
;--- Load the old data nodes (if they have not been loaded yet)
F I=2,102,108 D:'$D(RORNODE(I))
. S RORNODE(I)=$G(^IMR(158,IMRIEN,I))
;--- Prepare the data
F I=1:1 S BUF=$P($T(INIDIAGS+I),";;",2,99) Q:BUF="" D
. S DIEN=+BUF
. S TMP=$P(BUF,U,2),DX=$P(RORNODE(+TMP),U,$P(TMP,";",2))
. S DX=$TR(DX,"DPN0","12") Q:DX=""
. S TMP=$P(BUF,U,3),DATE=$P(RORNODE(+TMP),U,$P(TMP,";",2))
. ;---
. S IENS="+"_I_","_RORIEN_","
. S RORFDA(799.41,IENS,.01)=DIEN
. S RORFDA(799.41,IENS,.02)=DX
. S RORFDA(799.41,IENS,.03)=DATE
. S RORILST(I)=DIEN
;--- Store the data
D:$D(RORFDA)>1
. D UPDATE^DIE(,"RORFDA","RORILST","RORMSG")
. I $G(DIERR) D Q
. . S RC=$$DBS^RORERR("RORMSG",-9,,,799.41)
;---
Q $S(RC<0:RC,1:0)
;
;***** TEMPORARY 'AFTER UPDATE' CALL-BACK ENTRY POINT
;
; RORIEN An IEN of the newly added registry record
; PATIEN Patient IEN
; REGIEN Registry IEN
;
; Return Values:
; <0 Error Code
; 0 Ok
;
POSTUPD(RORIEN,PATIEN,REGIEN) ;
N CODE,IEN158,IENS,RC,RORFDA,RORMSG,TMP
;--- Perform the standard HIV post-update actions
S RC=$$POSTUPD^RORUPD62(RORIEN,PATIEN,REGIEN) Q:RC<0 RC
;--- Check if the patient is in the ICR v2.1
S CODE=$$XOR^RORUTL03(PATIEN)
S IEN158=$O(^IMR(158,"B",CODE,"")) Q:IEN158'>0 0
S IENS=RORIEN_","
;--- Populate the DATE ENTERED with the date of first selection rule
S TMP=$$GET1^DIQ(798,IENS,3.2,"I",,"RORMSG")
D:$G(DIERR) DBS^RORERR("RORMSG",-9,,PATIEN,798,IENS)
S:TMP>0 RORFDA(798,IENS,1)=TMP
;--- Convert the patient's data
D:$$CNVPTDAT(IEN158,RORIEN)'<0
. ;--- Replace the 'Pending' flag with 'Active'
. S RORFDA(798,IENS,3)=0 ; STATUS (Pending -> Active)
. S RORFDA(798,IENS,11)="@" ; DON'T SEND
;--- Update the registry record if necessary
I $D(RORFDA)>1 D Q:RC<0 RC
. D FILE^DIE(,"RORFDA","RORMSG")
. S:$G(DIERR) RC=$$DBS^RORERR("RORMSG",-9,,PATIEN,798,IENS)
;---
Q 0
;
;***** CREATES THE NEW DATA NODE IN THE RECORD OF THE FILE #799.4
STORE(DSTN) ;
K ^RORDATA(799.4,RORIEN,DSTN)
S:RORNODE'="" ^RORDATA(799.4,RORIEN,DSTN)=RORNODE
S RORNODE=""
Q
;
;***** TRANSLATE THE SET OF CODES
TRANSL(SRCN,SRCP,DSTP,FROM,TO) ;
N TMP
S:'$D(RORNODE(SRCN)) RORNODE(SRCN)=$G(^IMR(158,IMRIEN,SRCN))
S TMP=$P(RORNODE(SRCN),U,SRCP)
S:TMP'="" $P(RORNODE,U,DSTP)=$TR(TMP,FROM,TO)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRORHIV03 6245 printed Dec 13, 2024@01:41:41 Page 2
RORHIV03 ;HCIOFO/SG - CONVERSION OF THE FILE #158 ; 5/12/05 2:53pm
+1 ;;1.5;CLINICAL CASE REGISTRIES;;Feb 17, 2006
+2 ;
+3 QUIT
+4 ;
+5 ;***** TRANSFERS THE CDC COMMENTS TO THE MULTIPLE #25
CDCOMM() ;
+1 NEW CNT,I,IENS,RC,RORBUF,RORFDA,RORMSG,TMP
+2 SET (CNT,RC)=0
+3 ;--- Load the old comments (non-empty ones)
+4 FOR I=3,2,1
Begin DoDot:1
+5 SET TMP=$GET(^IMR(158,IMRIEN,I+9))
+6 if (TMP'="")!CNT
SET RORBUF(I,0)=TMP
SET CNT=CNT+1
End DoDot:1
+7 ;--- Store the comments in the new word processing field
+8 if $DATA(RORBUF)>1
Begin DoDot:1
+9 SET IENS=RORIEN_","
+10 SET RORFDA(799.4,IENS,25)="RORBUF"
+11 DO UPDATE^DIE(,"RORFDA",,"RORMSG")
+12 IF $GET(DIERR)
Begin DoDot:2
+13 SET RC=$$DBS^RORERR("RORMSG",-9,,,799.4,IENS)
End DoDot:2
End DoDot:1
+14 QUIT $SELECT(RC<0:RC,1:0)
+15 ;
+16 ;***** TRANSFERS THE PATIENT'S DATA FROM FILE #158 TO FILE #799.4
+17 ;
+18 ; IMRIEN IEN of the IMMUNOLOGY CASE STUDY file record
+19 ; RORIEN IEN of the record of the ROR HIV RECORD file
+20 ;
+21 ; Return Values:
+22 ; <0 Error code
+23 ; 0 Ok
+24 ;
CNVPTDAT(IMRIEN,RORIEN) ;
+1 NEW DA,DIK,RC,RORNODE,TMP
+2 SET RORNODE=""
+3 ;--- Check the parameters
+4 IF '$DATA(^IMR(158,IMRIEN,0))
Begin DoDot:1
+5 SET RC=$$ERROR^RORERR(-88,,,,"IMRIEN",IMRIEN)
End DoDot:1
QUIT RC
+6 IF '$DATA(^RORDATA(799.4,RORIEN,0))
Begin DoDot:1
+7 SET RC=$$ERROR^RORERR(-88,,,,"RORIEN",RORIEN)
End DoDot:1
QUIT RC
+8 ;---
+9 SET RORNODE=^RORDATA(799.4,RORIEN,0)
+10 DO COPY(0,"42>2,23>3")
+11 DO COPY(1,"7>4")
+12 ; CLINICAL AIDS
IF $PIECE(RORNODE,U,2)=4
Begin DoDot:1
+13 SET $PIECE(RORNODE,U,2)=1
SET TMP=$PIECE(RORNODE,U,3)\1
+14 IF TMP<1000000
SET $PIECE(RORNODE,U,3)=""
QUIT
+15 if '$EXTRACT(TMP,4,5)
SET $EXTRACT(TMP,4,5)="01"
+16 if '$EXTRACT(TMP,6,7)
SET $EXTRACT(TMP,6,7)="01"
+17 SET $PIECE(RORNODE,U,3)=TMP
End DoDot:1
+18 IF '$TEST
SET $PIECE(RORNODE,U,2,3)=U
+19 DO STORE(0)
+20 ;---
+21 DO COPY(1,"6>1,34>5,9>9,10>10,11>11,12>12,13>13,14>14")
+22 DO COPY(2,"16>4")
+23 DO COPY(102,"8>7,23>8")
+24 DO COPY(110,"1>2,2>3")
+25 DO COPY(112,"5>6")
+26 DO STORE(9)
+27 ;---
+28 DO COPY(102,"19>5")
+29 DO COPY(110,"4>1,5>4")
+30 DO COPY(112,"7>2,8>3")
+31 DO STORE(11)
+32 ;---
+33 DO COPY(1,"16>2,17>3,18>4")
+34 DO COPY(2,"54>1")
+35 DO COPY(102,"10>7")
+36 DO COPY(110,"16>5")
+37 DO COPY(112,"6>6")
+38 DO STORE(12)
+39 ;---
+40 DO COPY(1,"26>3,20>6,28>7,29>8,30>9,31>10,32>12,21>13,22>14,23>15,24>17")
+41 DO TRANSL(1,19,5,"1,2,3","1,2,8")
+42 DO COPY(2,"21>1,23>2,53>4,55>18")
+43 DO COPY(102,"14>16")
+44 DO COPY(110,"3>11")
+45 DO STORE(14)
+46 ;---
+47 DO COPY(1,"35>1,36>9")
+48 DO COPY(2,"49>5")
DO TRANSL(2,50,7,"P,N,I,U","1,0,8,9")
+49 DO COPY(102,"20>11")
+50 DO COPY(108,"27>2,28>6,29>8,30>12")
+51 DO COPY(110,"17>3,18>4,19>13,20>14")
+52 DO STORE(16)
+53 ;---
+54 DO COPY(111,"10>1,11>2,12>3,13>4,14>5,1>6,2>7,3>8,4>9")
+55 DO STORE(18)
+56 ;---
+57 DO COPY(102,"21>1,22>3")
+58 DO COPY(108,"31>2")
+59 DO COPY(111,"5>4,6>5,7>6,8>7,9>8")
+60 DO STORE(20)
+61 ;---
+62 DO COPY(110,"6>1,7>2,8>4,9>5,10>6,11>7,12>8")
+63 DO COPY(112,"11>3")
+64 DO STORE(22)
+65 ;---
+66 DO TRANSL(110,13,1,"1,2,9","1,0,9")
+67 DO TRANSL(110,14,2,"1,2,9","1,0,9")
+68 DO TRANSL(110,15,3,"1,2,9","1,0,9")
+69 DO COPY(112,"1>4,2>5,3>6,4>7")
+70 DO STORE(23)
+71 ;---
+72 SET RC=$$INIDIAGS()
if RC<0
QUIT RC
+73 SET RC=$$CDCOMM()
if RC<0
QUIT RC
+74 ;--- Reindex the entry
+75 SET DIK="^RORDATA(799.4,"
SET DA=RORIEN
DO IX1^DIK
+76 QUIT 0
+77 ;
+78 ;***** COPY THE FIELD DATA
COPY(SRCN,PTLIST) ;
+1 NEW DSTP,I,SRCP,TMP
+2 if '$DATA(RORNODE(SRCN))
SET RORNODE(SRCN)=$GET(^IMR(158,IMRIEN,SRCN))
+3 FOR I=1:1
SET TMP=$PIECE(PTLIST,",",I)
if TMP=""
QUIT
Begin DoDot:1
+4 SET SRCP=+$PIECE(TMP,">")
SET DSTP=+$PIECE(TMP,">",2)
+5 SET TMP=$PIECE(RORNODE(SRCN),U,SRCP)
+6 if TMP'=""
SET $PIECE(RORNODE,U,DSTP)=TMP
End DoDot:1
+7 QUIT
+8 ;
+9 ;***** TRANSFER INITIAL DIAGNOSES
INIDIAGS() ;
+1 ;;01^2;24^108;1
+2 ;;02^2;25^108;2
+3 ;;03^102;15^108;3
+4 ;;04^2;26^108;4
+5 ;;05^2;27^108;5
+6 ;;06^2;28^108;6
+7 ;;07^2;29^108;7
+8 ;;08^2;30^108;8
+9 ;;09^2;31^108;9
+10 ;;10^2;32^108;10
+11 ;;11^2;33^108;11
+12 ;;12^2;34^108;12
+13 ;;13^2;35^108;13
+14 ;;14^1;36^108;14
+15 ;;15^2;37^108;15
+16 ;;16^2;38^108;16
+17 ;;17^2;39^108;17
+18 ;;18^102;16^108;18
+19 ;;19^2;40^108;19
+20 ;;20^2;41^108;20
+21 ;;21^2;42^108;21
+22 ;;22^102;17^108;22
+23 ;;23^2;43^108;23
+24 ;;24^2;44^108;24
+25 ;;25^2;45^108;25
+26 ;;26^2;46^108;26
+27 ;
+28 NEW BUF,DATE,DIAG,DIEN,I,IENS,RC,RORFDA,RORILST,RORMSG,TMP
+29 KILL ^RORDATA(799.4,RORIEN,10)
SET RC=0
+30 ;--- Load the old data nodes (if they have not been loaded yet)
+31 FOR I=2,102,108
if '$DATA(RORNODE(I))
Begin DoDot:1
+32 SET RORNODE(I)=$GET(^IMR(158,IMRIEN,I))
End DoDot:1
+33 ;--- Prepare the data
+34 FOR I=1:1
SET BUF=$PIECE($TEXT(INIDIAGS+I),";;",2,99)
if BUF=""
QUIT
Begin DoDot:1
+35 SET DIEN=+BUF
+36 SET TMP=$PIECE(BUF,U,2)
SET DX=$PIECE(RORNODE(+TMP),U,$PIECE(TMP,";",2))
+37 SET DX=$TRANSLATE(DX,"DPN0","12")
if DX=""
QUIT
+38 SET TMP=$PIECE(BUF,U,3)
SET DATE=$PIECE(RORNODE(+TMP),U,$PIECE(TMP,";",2))
+39 ;---
+40 SET IENS="+"_I_","_RORIEN_","
+41 SET RORFDA(799.41,IENS,.01)=DIEN
+42 SET RORFDA(799.41,IENS,.02)=DX
+43 SET RORFDA(799.41,IENS,.03)=DATE
+44 SET RORILST(I)=DIEN
End DoDot:1
+45 ;--- Store the data
+46 if $DATA(RORFDA)>1
Begin DoDot:1
+47 DO UPDATE^DIE(,"RORFDA","RORILST","RORMSG")
+48 IF $GET(DIERR)
Begin DoDot:2
+49 SET RC=$$DBS^RORERR("RORMSG",-9,,,799.41)
End DoDot:2
QUIT
End DoDot:1
+50 ;---
+51 QUIT $SELECT(RC<0:RC,1:0)
+52 ;
+53 ;***** TEMPORARY 'AFTER UPDATE' CALL-BACK ENTRY POINT
+54 ;
+55 ; RORIEN An IEN of the newly added registry record
+56 ; PATIEN Patient IEN
+57 ; REGIEN Registry IEN
+58 ;
+59 ; Return Values:
+60 ; <0 Error Code
+61 ; 0 Ok
+62 ;
POSTUPD(RORIEN,PATIEN,REGIEN) ;
+1 NEW CODE,IEN158,IENS,RC,RORFDA,RORMSG,TMP
+2 ;--- Perform the standard HIV post-update actions
+3 SET RC=$$POSTUPD^RORUPD62(RORIEN,PATIEN,REGIEN)
if RC<0
QUIT RC
+4 ;--- Check if the patient is in the ICR v2.1
+5 SET CODE=$$XOR^RORUTL03(PATIEN)
+6 SET IEN158=$ORDER(^IMR(158,"B",CODE,""))
if IEN158'>0
QUIT 0
+7 SET IENS=RORIEN_","
+8 ;--- Populate the DATE ENTERED with the date of first selection rule
+9 SET TMP=$$GET1^DIQ(798,IENS,3.2,"I",,"RORMSG")
+10 if $GET(DIERR)
DO DBS^RORERR("RORMSG",-9,,PATIEN,798,IENS)
+11 if TMP>0
SET RORFDA(798,IENS,1)=TMP
+12 ;--- Convert the patient's data
+13 if $$CNVPTDAT(IEN158,RORIEN)'<0
Begin DoDot:1
+14 ;--- Replace the 'Pending' flag with 'Active'
+15 ; STATUS (Pending -> Active)
SET RORFDA(798,IENS,3)=0
+16 ; DON'T SEND
SET RORFDA(798,IENS,11)="@"
End DoDot:1
+17 ;--- Update the registry record if necessary
+18 IF $DATA(RORFDA)>1
Begin DoDot:1
+19 DO FILE^DIE(,"RORFDA","RORMSG")
+20 if $GET(DIERR)
SET RC=$$DBS^RORERR("RORMSG",-9,,PATIEN,798,IENS)
End DoDot:1
if RC<0
QUIT RC
+21 ;---
+22 QUIT 0
+23 ;
+24 ;***** CREATES THE NEW DATA NODE IN THE RECORD OF THE FILE #799.4
STORE(DSTN) ;
+1 KILL ^RORDATA(799.4,RORIEN,DSTN)
+2 if RORNODE'=""
SET ^RORDATA(799.4,RORIEN,DSTN)=RORNODE
+3 SET RORNODE=""
+4 QUIT
+5 ;
+6 ;***** TRANSLATE THE SET OF CODES
TRANSL(SRCN,SRCP,DSTP,FROM,TO) ;
+1 NEW TMP
+2 if '$DATA(RORNODE(SRCN))
SET RORNODE(SRCN)=$GET(^IMR(158,IMRIEN,SRCN))
+3 SET TMP=$PIECE(RORNODE(SRCN),U,SRCP)
+4 if TMP'=""
SET $PIECE(RORNODE,U,DSTP)=$TRANSLATE(TMP,FROM,TO)
+5 QUIT
