Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RMIMU

RMIMU.m

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