- RMIMHL ;WPB/JLTP ; FIM HL7 UTILITY ; 20-SEPT-2002
- ;;1.0;FUNCTIONAL INDEPENDENCE;;Apr 15, 2003
- SND(X) ; Generate HL7 Message for Austin
- N ADMDT,CS,DA,DCDT,DIE,DME,DR,FS,HL,HLA,HLI,I,IDX,IFN,RC,RES,RM,T,TYPES
- S IFN=+$G(X)
- D INIT^HLFNC2("RMIM DRIVER",.HL) I $G(HL) Q -1
- S FS=HL("FS"),CS=$E(HL("ECH")),RC=$E(HL("ECH"),2)
- F I=0:1:8 S RM(I)=$G(^RMIM(783,IFN,I))
- S HLA("HLS",1)=$$PID,HLA("HLS",2)=$$PV1,HLA("HLS",3)=$$NTE
- S HLA("HLS",4)=$$OBR,HLA("HLS",5)=$$OBXDG,IDX=5
- S TYPES="ADMISSION^DISCHARGE^INTERIM^FOLLOW-UP^GOALS" F T=1:1:5 D
- .Q:RM(T+3)?."^" S IDX=IDX+1,HLA("HLS",IDX)=$$OBXS(T)
- ;S (I,HLI)=0 F S I=$O(^RMIM(783,IFN,100,I)) Q:'I S X=^(I,0) D
- ;.S HLI=HLI+1,IDX=IDX+1,HLA("HLS",IDX)=$$OBXN(X)
- S X=$G(^RMIM(783,IFN,0)),ADMDT=$P(X,U,10),DCDT=$P(X,U,11),DFN=$P(X,U,3)
- S X=DFN_U_ADMDT_U_DCDT
- I DCDT]"",ADMDT]"" D DME^RMIMRP(.DME,X) D
- .S I=0 F S I=$O(DME(I)) Q:'I D
- ..S DME="OBX"_FS_I_FS_"TX"_FS_"DME ITEMS"_FS_FS_DME(I)
- ..S $P(DME,FS,12)="F"
- ..S IDX=IDX+1,HLA("HLS",IDX)=DME
- D GENERATE^HLMA("RMIM DRIVER","LM",1,.RES)
- S DIE="^RMIM(783,",DA=IFN,DR=".13///T" D ^DIE
- Q RES
- PID() ; Build and Return the PID Segment
- N ADDR,CASE,CITY,DFN,DOB,MARRIED,PHONE,PID,PNM,RACE,SEX
- N SSN,STATE,STREET,ZIP
- S PID=""
- S SSN=$P(RM(0),U,4),$P(PID,FS,2)=SSN,$P(PID,FS,19)=SSN
- S DFN=$P(RM(0),U,3),$P(PID,FS,3)=DFN
- S PNM=$$HLNAME^HLFNC($P(^DPT(DFN,0),U)),$P(PID,FS,5)=PNM
- S DOB=$$HLDATE^HLFNC($P(RM(0),U,5)),$P(PID,FS,7)=DOB
- S CASE=$P(RM(0),U,2),$P(PID,FS,4)=IFN_CS_CASE
- S STREET=$P(RM(1),U,1)
- S CITY=$P(RM(1),U,2)
- S STATE=$P(RM(1),U,3)
- S ZIP=$P(RM(1),U,4)
- ;S ADDR=$$HLADDR^HLFNC(STREET,CITY_U_STATE_U_ZIP),$P(PID,FS,11)=ADDR
- S ADDR=STREET_U_U_CITY_U_STATE_U_ZIP_U_"USA",$P(PID,FS,11)=ADDR
- S PHONE=$$HLPHONE^HLFNC($P(RM(1),U,5)),$P(PID,FS,13)=PHONE
- S SEX=$P(RM(1),U,6),$P(PID,FS,8)=SEX
- S RACE=$P(RM(1),U,7),$P(PID,FS,10)=RACE
- S MARRIED=$P(RM(1),U,8),$P(PID,FS,16)=MARRIED
- S MIL=$P(RM(1),U,9),$P(PID,FS,27)=MIL
- Q "PID"_FS_PID
- OBR() ; KEY FIELDS
- N ADMIT,ASSDT,CARE,DOB,ETIOL,FAC,IMPAIR,OBR,ONSET,SSN,UNIV
- S OBR="",UNIV=""
- S SSN=$P(RM(0),U,4),$P(UNIV,CS)=SSN
- S DOB=$$HLDATE^HLFNC($P(RM(0),U,5)),$P(UNIV,CS,2)=DOB
- S CARE=$P(RM(0),U,7),$P(UNIV,CS,3)=$$CCV(CARE)
- S ONSET=$$HLDATE^HLFNC($P(RM(0),U,9)),$P(UNIV,CS,4)=ONSET
- S IMPAIR=$P(RM(0),U,8),$P(UNIV,CS,5)=IMPAIR
- S ADMIT=$$HLDATE^HLFNC($P(RM(0),U,10)),$P(UNIV,CS,6)=ADMIT
- S FAC=$P(RM(0),U,6)
- I $L(FAC)<4 S FAC=FAC_" "
- I $L(FAC)<4 S FAC=FAC_" "
- S $P(UNIV,CS,7)=FAC
- S $P(OBR,FS,4)=UNIV
- S ETIOL=$P(RM(2),U,10),$P(OBR,FS,13)=ETIOL
- S ASSDT=$$HLDATE^HLFNC($P(RM(0),U,12)),$P(OBR,FS,7)=ASSDT
- Q "OBR"_FS_OBR
- PV1() ; EPISODE OF CARE DATA
- N ADMCL,ADMDT,CARECL,DCDT,PV1
- S PV1=""
- S ADMCL=$P(RM(2),U),$P(PV1,FS,4)=ADMCL
- S CARECL=$P(RM(0),U,7),$P(PV1,FS,2)=$$CCV(CARECL)
- S ADMDT=$$HLDATE^HLFNC($P(RM(0),U,10)),$P(PV1,FS,44)=ADMDT
- S DCDT=$$HLDATE^HLFNC($P(RM(0),U,11)),$P(PV1,FS,45)=DCDT
- Q "PV1"_FS_PV1
- CCV(X) ; CARE CLASS CONVERSION
- Q $S(X=1:10,X=2:"04",X=3:"09",1:X)
- NTE() ; TRANSFERS
- N COM S COM=""
- S COM=$P(RM(2),U,4,9)
- F RM=1:1:6 S $P(COM,U,RM)=$$HLDATE^HLFNC($P(COM,U,RM))
- S COM=$TR(COM,U,CS)
- Q "NTE"_FS_"1"_FS_"L"_FS_COM
- OBXDG() ; DIAGNOSIS CODES
- N ASIA,ICD,OBX
- S ASIA=$P(RM(2),U,11),ICD=$TR(RM(3),U,CS)
- S OBX="1"_FS_"CE"_FS_"DIAGNOSIS CODES"_FS_ASIA_CS_ICD
- S $P(OBX,FS,11)="F"
- Q "OBX"_FS_OBX
- OBXS(T) ; FIM SCORES
- N OBX,SCORES,TYPE
- S TYPE=$P(TYPES,U,T),OBX="",SCORES=$TR(RM(T+3),U,CS),$P(OBX,FS,5)=SCORES
- S $P(OBX,FS,1)=IDX-5,$P(OBX,FS,2)="NM",$P(OBX,FS,3)=TYPE
- S $P(OBX,FS,11)="F"
- Q "OBX"_FS_OBX
- OBXN(X) ; CASE NOTES
- N OBX S $P(OBX,FS)=HLI,$P(OBX,FS,2)="FT",$P(OBX,FS,3)="CASE NOTES"
- S $P(OBX,FS,11)="F",$P(OBX,FS,5)=X
- Q "OBX"_FS_OBX
- TASK ; NIGHTLY JOB
- I '$$FIND1^DIC(4.2,"","X","Q-FIM.DOMAIN.EXT","B") D Q
- .N TX,XMDUN,XMDUZ,XMSUB,XMTEXT,XMY,XMZ
- .S TX(1,0)="The domain Q-FIM.DOMAIN.EXT does not exist in your DOMAIN "
- .S TX(2,0)="file."
- .S TX(3,0)="Ask your IRM to install patch XM*DBA*150."
- .S TX(4,0)="You will not be able to transmit data to FSOD until this"
- .S TX(5,0)="patch has been installed."
- .S (XMDUN,XMDUZ)="FSOD TRANSMISSION",XMSUB="Missing Domain"
- .S XMTEXT="TX(",XMY("G.RMIM FSOD")="" D ^XMD
- S IFN=0 F S IFN=$O(^RMIM(783,"ATRAN",1,IFN)) Q:'IFN D
- .Q:'$D(^RMIM(783,IFN,0))
- .S STAT=$$SND(IFN)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMIMHL 4330 printed Mar 13, 2025@20:59:42 Page 2
- RMIMHL ;WPB/JLTP ; FIM HL7 UTILITY ; 20-SEPT-2002
- +1 ;;1.0;FUNCTIONAL INDEPENDENCE;;Apr 15, 2003
- SND(X) ; Generate HL7 Message for Austin
- +1 NEW ADMDT,CS,DA,DCDT,DIE,DME,DR,FS,HL,HLA,HLI,I,IDX,IFN,RC,RES,RM,T,TYPES
- +2 SET IFN=+$GET(X)
- +3 DO INIT^HLFNC2("RMIM DRIVER",.HL)
- IF $GET(HL)
- QUIT -1
- +4 SET FS=HL("FS")
- SET CS=$EXTRACT(HL("ECH"))
- SET RC=$EXTRACT(HL("ECH"),2)
- +5 FOR I=0:1:8
- SET RM(I)=$GET(^RMIM(783,IFN,I))
- +6 SET HLA("HLS",1)=$$PID
- SET HLA("HLS",2)=$$PV1
- SET HLA("HLS",3)=$$NTE
- +7 SET HLA("HLS",4)=$$OBR
- SET HLA("HLS",5)=$$OBXDG
- SET IDX=5
- +8 SET TYPES="ADMISSION^DISCHARGE^INTERIM^FOLLOW-UP^GOALS"
- FOR T=1:1:5
- Begin DoDot:1
- +9 if RM(T+3)?."^"
- QUIT
- SET IDX=IDX+1
- SET HLA("HLS",IDX)=$$OBXS(T)
- End DoDot:1
- +10 ;S (I,HLI)=0 F S I=$O(^RMIM(783,IFN,100,I)) Q:'I S X=^(I,0) D
- +11 ;.S HLI=HLI+1,IDX=IDX+1,HLA("HLS",IDX)=$$OBXN(X)
- +12 SET X=$GET(^RMIM(783,IFN,0))
- SET ADMDT=$PIECE(X,U,10)
- SET DCDT=$PIECE(X,U,11)
- SET DFN=$PIECE(X,U,3)
- +13 SET X=DFN_U_ADMDT_U_DCDT
- +14 IF DCDT]""
- IF ADMDT]""
- DO DME^RMIMRP(.DME,X)
- Begin DoDot:1
- +15 SET I=0
- FOR
- SET I=$ORDER(DME(I))
- if 'I
- QUIT
- Begin DoDot:2
- +16 SET DME="OBX"_FS_I_FS_"TX"_FS_"DME ITEMS"_FS_FS_DME(I)
- +17 SET $PIECE(DME,FS,12)="F"
- +18 SET IDX=IDX+1
- SET HLA("HLS",IDX)=DME
- End DoDot:2
- End DoDot:1
- +19 DO GENERATE^HLMA("RMIM DRIVER","LM",1,.RES)
- +20 SET DIE="^RMIM(783,"
- SET DA=IFN
- SET DR=".13///T"
- DO ^DIE
- +21 QUIT RES
- PID() ; Build and Return the PID Segment
- +1 NEW ADDR,CASE,CITY,DFN,DOB,MARRIED,PHONE,PID,PNM,RACE,SEX
- +2 NEW SSN,STATE,STREET,ZIP
- +3 SET PID=""
- +4 SET SSN=$PIECE(RM(0),U,4)
- SET $PIECE(PID,FS,2)=SSN
- SET $PIECE(PID,FS,19)=SSN
- +5 SET DFN=$PIECE(RM(0),U,3)
- SET $PIECE(PID,FS,3)=DFN
- +6 SET PNM=$$HLNAME^HLFNC($PIECE(^DPT(DFN,0),U))
- SET $PIECE(PID,FS,5)=PNM
- +7 SET DOB=$$HLDATE^HLFNC($PIECE(RM(0),U,5))
- SET $PIECE(PID,FS,7)=DOB
- +8 SET CASE=$PIECE(RM(0),U,2)
- SET $PIECE(PID,FS,4)=IFN_CS_CASE
- +9 SET STREET=$PIECE(RM(1),U,1)
- +10 SET CITY=$PIECE(RM(1),U,2)
- +11 SET STATE=$PIECE(RM(1),U,3)
- +12 SET ZIP=$PIECE(RM(1),U,4)
- +13 ;S ADDR=$$HLADDR^HLFNC(STREET,CITY_U_STATE_U_ZIP),$P(PID,FS,11)=ADDR
- +14 SET ADDR=STREET_U_U_CITY_U_STATE_U_ZIP_U_"USA"
- SET $PIECE(PID,FS,11)=ADDR
- +15 SET PHONE=$$HLPHONE^HLFNC($PIECE(RM(1),U,5))
- SET $PIECE(PID,FS,13)=PHONE
- +16 SET SEX=$PIECE(RM(1),U,6)
- SET $PIECE(PID,FS,8)=SEX
- +17 SET RACE=$PIECE(RM(1),U,7)
- SET $PIECE(PID,FS,10)=RACE
- +18 SET MARRIED=$PIECE(RM(1),U,8)
- SET $PIECE(PID,FS,16)=MARRIED
- +19 SET MIL=$PIECE(RM(1),U,9)
- SET $PIECE(PID,FS,27)=MIL
- +20 QUIT "PID"_FS_PID
- OBR() ; KEY FIELDS
- +1 NEW ADMIT,ASSDT,CARE,DOB,ETIOL,FAC,IMPAIR,OBR,ONSET,SSN,UNIV
- +2 SET OBR=""
- SET UNIV=""
- +3 SET SSN=$PIECE(RM(0),U,4)
- SET $PIECE(UNIV,CS)=SSN
- +4 SET DOB=$$HLDATE^HLFNC($PIECE(RM(0),U,5))
- SET $PIECE(UNIV,CS,2)=DOB
- +5 SET CARE=$PIECE(RM(0),U,7)
- SET $PIECE(UNIV,CS,3)=$$CCV(CARE)
- +6 SET ONSET=$$HLDATE^HLFNC($PIECE(RM(0),U,9))
- SET $PIECE(UNIV,CS,4)=ONSET
- +7 SET IMPAIR=$PIECE(RM(0),U,8)
- SET $PIECE(UNIV,CS,5)=IMPAIR
- +8 SET ADMIT=$$HLDATE^HLFNC($PIECE(RM(0),U,10))
- SET $PIECE(UNIV,CS,6)=ADMIT
- +9 SET FAC=$PIECE(RM(0),U,6)
- +10 IF $LENGTH(FAC)<4
- SET FAC=FAC_" "
- +11 IF $LENGTH(FAC)<4
- SET FAC=FAC_" "
- +12 SET $PIECE(UNIV,CS,7)=FAC
- +13 SET $PIECE(OBR,FS,4)=UNIV
- +14 SET ETIOL=$PIECE(RM(2),U,10)
- SET $PIECE(OBR,FS,13)=ETIOL
- +15 SET ASSDT=$$HLDATE^HLFNC($PIECE(RM(0),U,12))
- SET $PIECE(OBR,FS,7)=ASSDT
- +16 QUIT "OBR"_FS_OBR
- PV1() ; EPISODE OF CARE DATA
- +1 NEW ADMCL,ADMDT,CARECL,DCDT,PV1
- +2 SET PV1=""
- +3 SET ADMCL=$PIECE(RM(2),U)
- SET $PIECE(PV1,FS,4)=ADMCL
- +4 SET CARECL=$PIECE(RM(0),U,7)
- SET $PIECE(PV1,FS,2)=$$CCV(CARECL)
- +5 SET ADMDT=$$HLDATE^HLFNC($PIECE(RM(0),U,10))
- SET $PIECE(PV1,FS,44)=ADMDT
- +6 SET DCDT=$$HLDATE^HLFNC($PIECE(RM(0),U,11))
- SET $PIECE(PV1,FS,45)=DCDT
- +7 QUIT "PV1"_FS_PV1
- CCV(X) ; CARE CLASS CONVERSION
- +1 QUIT $SELECT(X=1:10,X=2:"04",X=3:"09",1:X)
- NTE() ; TRANSFERS
- +1 NEW COM
- SET COM=""
- +2 SET COM=$PIECE(RM(2),U,4,9)
- +3 FOR RM=1:1:6
- SET $PIECE(COM,U,RM)=$$HLDATE^HLFNC($PIECE(COM,U,RM))
- +4 SET COM=$TRANSLATE(COM,U,CS)
- +5 QUIT "NTE"_FS_"1"_FS_"L"_FS_COM
- OBXDG() ; DIAGNOSIS CODES
- +1 NEW ASIA,ICD,OBX
- +2 SET ASIA=$PIECE(RM(2),U,11)
- SET ICD=$TRANSLATE(RM(3),U,CS)
- +3 SET OBX="1"_FS_"CE"_FS_"DIAGNOSIS CODES"_FS_ASIA_CS_ICD
- +4 SET $PIECE(OBX,FS,11)="F"
- +5 QUIT "OBX"_FS_OBX
- OBXS(T) ; FIM SCORES
- +1 NEW OBX,SCORES,TYPE
- +2 SET TYPE=$PIECE(TYPES,U,T)
- SET OBX=""
- SET SCORES=$TRANSLATE(RM(T+3),U,CS)
- SET $PIECE(OBX,FS,5)=SCORES
- +3 SET $PIECE(OBX,FS,1)=IDX-5
- SET $PIECE(OBX,FS,2)="NM"
- SET $PIECE(OBX,FS,3)=TYPE
- +4 SET $PIECE(OBX,FS,11)="F"
- +5 QUIT "OBX"_FS_OBX
- OBXN(X) ; CASE NOTES
- +1 NEW OBX
- SET $PIECE(OBX,FS)=HLI
- SET $PIECE(OBX,FS,2)="FT"
- SET $PIECE(OBX,FS,3)="CASE NOTES"
- +2 SET $PIECE(OBX,FS,11)="F"
- SET $PIECE(OBX,FS,5)=X
- +3 QUIT "OBX"_FS_OBX
- TASK ; NIGHTLY JOB
- +1 IF '$$FIND1^DIC(4.2,"","X","Q-FIM.DOMAIN.EXT","B")
- Begin DoDot:1
- +2 NEW TX,XMDUN,XMDUZ,XMSUB,XMTEXT,XMY,XMZ
- +3 SET TX(1,0)="The domain Q-FIM.DOMAIN.EXT does not exist in your DOMAIN "
- +4 SET TX(2,0)="file."
- +5 SET TX(3,0)="Ask your IRM to install patch XM*DBA*150."
- +6 SET TX(4,0)="You will not be able to transmit data to FSOD until this"
- +7 SET TX(5,0)="patch has been installed."
- +8 SET (XMDUN,XMDUZ)="FSOD TRANSMISSION"
- SET XMSUB="Missing Domain"
- +9 SET XMTEXT="TX("
- SET XMY("G.RMIM FSOD")=""
- DO ^XMD
- End DoDot:1
- QUIT
- +10 SET IFN=0
- FOR
- SET IFN=$ORDER(^RMIM(783,"ATRAN",1,IFN))
- if 'IFN
- QUIT
- Begin DoDot:1
- +11 if '$DATA(^RMIM(783,IFN,0))
- QUIT
- +12 SET STAT=$$SND(IFN)
- End DoDot:1
- +13 QUIT
