RMIMU ;WPB/JLTP,THT - FUNCTIONAL INDEPENDENCE UTILITIES ;04/11/19
;;1.0;FUNCTIONAL INDEPENDENCE;**10**;;Build 4
A(X) ; Add New Record to FIM Database
N AD,CASE,DA,DFN,DIE,DOB,DR,FAC,FACI,I,IFN,IG,OD,OK,OP,TYP
S CASE=+X,X=$P(X,U,2,9),OK=1 F I=1:1:7 I $P(X,U,I)="" S OK=0 Q
I 'OK Q $$ERR(-1)
S DFN=+X,SSN=$P(X,U,2),DOB=$P(X,U,3),FAC=$P(X,U,4),TYP=$P(X,U,5)
S IG=$P(X,U,6),OD=$P(X,U,7),AD=$P(X,U,8),OP="A"
S X=$$NFE(CASE),IFN=+X,CASE=$P(X,U,2) I X'>0 Q $$ERR(-2)
S X=IFN_U_CASE_U_DFN_U_SSN_U_DOB_U_FAC_U_TYP_U_IG_U_OD_U_AD
I '$$CF(X) Q $$ERR(-7)
Q IFN_U_CASE
NFE(C) ; Create Record and Return IFN
N CASE,DA,DIC,DIE,DINUM,DR,IFN,X,Y,RMIMFDA,RMIMERR
S CASE=+$G(C)
L +^RMIM(783,0):1 S X=$P(^RMIM(783,0),U,4)+1
F Q:'$D(^RMIM(783,X,0)) S X=X+1
L +^RMIM(783.9,1,0):1
I 'CASE D
.S CASE=$P(^RMIM(783.9,1,0),U,2)+1
.F Q:'$D(^RMIM(783,"CASE",CASE)) S CASE=CASE+1
; VSR - THT RMIM*1*10 replace //// with database FileMan calls
S IFN=X
S RMIMFDA(783,"+"_IFN_",",.01)=IFN
S RMIMFDA(783,"+"_IFN_",",.02)=CASE
D UPDATE^DIE("","RMIMFDA",,"RMIMERR")
S $P(^RMIM(783.9,1,0),U,2)=CASE
L -^RMIM(783,0) L -^RMIM(783.9,1,0)
Q IFN_U_CASE
E(X) ; Edit Existing Record
N CASE,CE,IFN,P,SENT,STATUS,X1
S CASE=+X,IFN=$O(^RMIM(783,"CASE",CASE,0)) Q:'IFN $$ERR(-6)
S X1=^RMIM(783,IFN,0),SENT=$P(X1,U,13)
F P=5,9:1:12 S:$P(X1,U,P) $P(X1,U,P)=$$FMTE^XLFDT($P(X1,U,P),5)
S CE=0 F P=2:1:9 I $P(X,U,P)'=$P(X1,U,P+1) S CE=1 Q
I 0,CE,SENT D Q STATUS
.S STATUS=$$D(X) Q:STATUS<1
.S STATUS=$$A(X)
S X=IFN_U_X
S STATUS=$$CF(X) I 'STATUS Q $$ERR(-7)
Q IFN_U_CASE
D(X) ; Mark Record for Deletion
Q 1 ;Not Currently Used... Maybe Later
N CASE,DA,DIE,DR,IFN,RMIMDFA,RMIMERR
S CASE=+X,IFN=$O(^RMIM(783,"CASE",CASE,0)) Q:'IFN $$ERR(-6)
S DA=IFN,DIE="^RMIM(783,",DR=".12////^S X=DT;.14////D" D ^DIE
Q IFN_U_CASE
CF(VAL) ; File Critical Fields
N DA,DIE,DR,EDIT,FLD,LINE,PCE,VAAR,X,Y
S DR="" F LINE=1:1 S TEXT=$P($T(CRIT+LINE),";;",2) Q:TEXT="" D
.S FLD=$P(TEXT,U),PCE=$P(TEXT,U,2),VAR=$P(TEXT,U,3)
.I PCE S EDIT=FLD_"///"_$P(VAL,U,PCE)
.E I VAR]"" S EDIT=FLD_"///^S X="_VAR
.I ($L(DR)+$L(EDIT))>200 D
..S DA=+VAL,DIE="^RMIM(783," D ^DIE S DR=""
.S:DR]"" DR=DR_";" S DR=DR_EDIT
I DR]"" S DA=+VAL,DIE="^RMIM(783," D ^DIE
Q 1
GC(RMIMR) ; Retrieve Critical Fields for a Case
N FLD,GN,GP,LINE,N,P,X
S IFN=+RMIMR(1)
F LINE=1:1 S TEXT=$P($T(CRIT+LINE),";;",2) Q:TEXT="" D
.S FLD=$P(TEXT,U),P=$P(TEXT,U,2) Q:'P
.S X=$P(^DD(783,+FLD,0),U,4),GN=$P(X,";"),GP=$P(X,";",2)
.I FLD'=+FLD S $P(RMIMR(1),U,P)=$$GET1^DIQ(783,IFN,+FLD) Q
.S X=$P($G(^RMIM(783,IFN,GN)),U,GP)
.I X S $P(RMIMR(1),U,P)=$$FMTE^XLFDT(X,5)
Q
ERR(E) ; Return Error Message
Q E_U_$P($T(ERMSG+$$ABS^XLFMTH(E)),";;",2)
ERMSG ; Error Messages
;;Missing Required Data
;;New Record Could Not Be Created
;;Invalid Facility Number
;;No Data Received
;;Invalid Operation Code
;;Case # Not Found
;;Error Filing Critical Fields
;;Error Retrieving Patient Data
;;
CRIT ; Required Identifier Fields
;;.03/^3
;;.04/^4
;;.05^5
;;.06/^6
;;.07/^7
;;.08/^8
;;.09^9
;;.1^10
;;.12/^^DT
;;.14/^^OP
;;.15/^^1
;;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMIMU 3178 printed Dec 13, 2024@01:55:06 Page 2
RMIMU ;WPB/JLTP,THT - FUNCTIONAL INDEPENDENCE UTILITIES ;04/11/19
+1 ;;1.0;FUNCTIONAL INDEPENDENCE;**10**;;Build 4
A(X) ; Add New Record to FIM Database
+1 NEW AD,CASE,DA,DFN,DIE,DOB,DR,FAC,FACI,I,IFN,IG,OD,OK,OP,TYP
+2 SET CASE=+X
SET X=$PIECE(X,U,2,9)
SET OK=1
FOR I=1:1:7
IF $PIECE(X,U,I)=""
SET OK=0
QUIT
+3 IF 'OK
QUIT $$ERR(-1)
+4 SET DFN=+X
SET SSN=$PIECE(X,U,2)
SET DOB=$PIECE(X,U,3)
SET FAC=$PIECE(X,U,4)
SET TYP=$PIECE(X,U,5)
+5 SET IG=$PIECE(X,U,6)
SET OD=$PIECE(X,U,7)
SET AD=$PIECE(X,U,8)
SET OP="A"
+6 SET X=$$NFE(CASE)
SET IFN=+X
SET CASE=$PIECE(X,U,2)
IF X'>0
QUIT $$ERR(-2)
+7 SET X=IFN_U_CASE_U_DFN_U_SSN_U_DOB_U_FAC_U_TYP_U_IG_U_OD_U_AD
+8 IF '$$CF(X)
QUIT $$ERR(-7)
+9 QUIT IFN_U_CASE
NFE(C) ; Create Record and Return IFN
+1 NEW CASE,DA,DIC,DIE,DINUM,DR,IFN,X,Y,RMIMFDA,RMIMERR
+2 SET CASE=+$GET(C)
+3 LOCK +^RMIM(783,0):1
SET X=$PIECE(^RMIM(783,0),U,4)+1
+4 FOR
if '$DATA(^RMIM(783,X,0))
QUIT
SET X=X+1
+5 LOCK +^RMIM(783.9,1,0):1
+6 IF 'CASE
Begin DoDot:1
+7 SET CASE=$PIECE(^RMIM(783.9,1,0),U,2)+1
+8 FOR
if '$DATA(^RMIM(783,"CASE",CASE))
QUIT
SET CASE=CASE+1
End DoDot:1
+9 ; VSR - THT RMIM*1*10 replace //// with database FileMan calls
+10 SET IFN=X
+11 SET RMIMFDA(783,"+"_IFN_",",.01)=IFN
+12 SET RMIMFDA(783,"+"_IFN_",",.02)=CASE
+13 DO UPDATE^DIE("","RMIMFDA",,"RMIMERR")
+14 SET $PIECE(^RMIM(783.9,1,0),U,2)=CASE
+15 LOCK -^RMIM(783,0)
LOCK -^RMIM(783.9,1,0)
+16 QUIT IFN_U_CASE
E(X) ; Edit Existing Record
+1 NEW CASE,CE,IFN,P,SENT,STATUS,X1
+2 SET CASE=+X
SET IFN=$ORDER(^RMIM(783,"CASE",CASE,0))
if 'IFN
QUIT $$ERR(-6)
+3 SET X1=^RMIM(783,IFN,0)
SET SENT=$PIECE(X1,U,13)
+4 FOR P=5,9:1:12
if $PIECE(X1,U,P)
SET $PIECE(X1,U,P)=$$FMTE^XLFDT($PIECE(X1,U,P),5)
+5 SET CE=0
FOR P=2:1:9
IF $PIECE(X,U,P)'=$PIECE(X1,U,P+1)
SET CE=1
QUIT
+6 IF 0
IF CE
IF SENT
Begin DoDot:1
+7 SET STATUS=$$D(X)
if STATUS<1
QUIT
+8 SET STATUS=$$A(X)
End DoDot:1
QUIT STATUS
+9 SET X=IFN_U_X
+10 SET STATUS=$$CF(X)
IF 'STATUS
QUIT $$ERR(-7)
+11 QUIT IFN_U_CASE
D(X) ; Mark Record for Deletion
+1 ;Not Currently Used... Maybe Later
QUIT 1
+2 NEW CASE,DA,DIE,DR,IFN,RMIMDFA,RMIMERR
+3 SET CASE=+X
SET IFN=$ORDER(^RMIM(783,"CASE",CASE,0))
if 'IFN
QUIT $$ERR(-6)
+4 SET DA=IFN
SET DIE="^RMIM(783,"
SET DR=".12////^S X=DT;.14////D"
DO ^DIE
+5 QUIT IFN_U_CASE
CF(VAL) ; File Critical Fields
+1 NEW DA,DIE,DR,EDIT,FLD,LINE,PCE,VAAR,X,Y
+2 SET DR=""
FOR LINE=1:1
SET TEXT=$PIECE($TEXT(CRIT+LINE),";;",2)
if TEXT=""
QUIT
Begin DoDot:1
+3 SET FLD=$PIECE(TEXT,U)
SET PCE=$PIECE(TEXT,U,2)
SET VAR=$PIECE(TEXT,U,3)
+4 IF PCE
SET EDIT=FLD_"///"_$PIECE(VAL,U,PCE)
+5 IF '$TEST
IF VAR]""
SET EDIT=FLD_"///^S X="_VAR
+6 IF ($LENGTH(DR)+$LENGTH(EDIT))>200
Begin DoDot:2
+7 SET DA=+VAL
SET DIE="^RMIM(783,"
DO ^DIE
SET DR=""
End DoDot:2
+8 if DR]""
SET DR=DR_";"
SET DR=DR_EDIT
End DoDot:1
+9 IF DR]""
SET DA=+VAL
SET DIE="^RMIM(783,"
DO ^DIE
+10 QUIT 1
GC(RMIMR) ; Retrieve Critical Fields for a Case
+1 NEW FLD,GN,GP,LINE,N,P,X
+2 SET IFN=+RMIMR(1)
+3 FOR LINE=1:1
SET TEXT=$PIECE($TEXT(CRIT+LINE),";;",2)
if TEXT=""
QUIT
Begin DoDot:1
+4 SET FLD=$PIECE(TEXT,U)
SET P=$PIECE(TEXT,U,2)
if 'P
QUIT
+5 SET X=$PIECE(^DD(783,+FLD,0),U,4)
SET GN=$PIECE(X,";")
SET GP=$PIECE(X,";",2)
+6 IF FLD'=+FLD
SET $PIECE(RMIMR(1),U,P)=$$GET1^DIQ(783,IFN,+FLD)
QUIT
+7 SET X=$PIECE($GET(^RMIM(783,IFN,GN)),U,GP)
+8 IF X
SET $PIECE(RMIMR(1),U,P)=$$FMTE^XLFDT(X,5)
End DoDot:1
+9 QUIT
ERR(E) ; Return Error Message
+1 QUIT E_U_$PIECE($TEXT(ERMSG+$$ABS^XLFMTH(E)),";;",2)
ERMSG ; Error Messages
+1 ;;Missing Required Data
+2 ;;New Record Could Not Be Created
+3 ;;Invalid Facility Number
+4 ;;No Data Received
+5 ;;Invalid Operation Code
+6 ;;Case # Not Found
+7 ;;Error Filing Critical Fields
+8 ;;Error Retrieving Patient Data
+9 ;;
CRIT ; Required Identifier Fields
+1 ;;.03/^3
+2 ;;.04/^4
+3 ;;.05^5
+4 ;;.06/^6
+5 ;;.07/^7
+6 ;;.08/^8
+7 ;;.09^9
+8 ;;.1^10
+9 ;;.12/^^DT
+10 ;;.14/^^OP
+11 ;;.15/^^1
+12 ;;
