IBTASDB ;EDE/TPF - MAIN RTN FOR VTU VISTA TABLE UTILITY
;;2.0;INTEGRATED BILLING;**742**;;Build 36
;;Per VA Directive 6402, this routine should not be modified.
;
Q
;
POST(RESULT,ARG) ;EP - GENERIC CALL FOR IBTASDB
N COMPRES,FDAERROR,NOW,POSTFDA,POSTRESULT,PURLOGDT,PUTFDA,PUTRESULT,RTN,X,X1,X2
;
S NOW=$$NOW^XLFDT
S X1=$P(NOW,".")
S X2=2 ;SHOULD BE 30 ON RELEASE. COULD BE A SITE PARAM
D C^%DTC
S PURLOGDT=X
S RTN=$T(+0)
S NAMESPACE=RTN_U_NOW_U_"DEBUG DUMP"
S ^XTMP(NAMESPACE,0)=PURLOGDT_U_$P(NOW,".")_U_"VTU FILE UPDATE LOG"
M ^XTMP(NAMESPACE,"ARG")=ARG
;
D CONVERTTOFDA^IBTASDBUTL(.ARG,.POSTFDA,.PUTFDA,.FDAERROR) ;CONVERT INCOMING ARG TO POSTFDA AND PUTFDA
;
I '$D(PUTFDA),'$D(POSTFDA),$D(FDAERROR) D Q ;IF AN FDA ERROR THEN CAN'T DO CALLS ANYWAY
.M COMPRES=FDAERROR
.K RESULT
.D JSON(.RESULT,.COMPRES)
.M ^XTMP(NAMESPACE,"ARG","PUT RESULT")=RESULT
;
K RESULT
;
I $D(POSTFDA) D POSTADD(.POSTRESULT,.POSTFDA)
M ^XTMP(NAMESPACE,"ARG","POSTADD RESULT")=RESULT
;
I $D(PUTFDA) D PUT(.PUTRESULT,.PUTFDA)
;
M COMPRES=POSTRESULT
M COMPRES=PUTRESULT
M COMPRES=FDAERROR
;
D JSON(.RESULT,.COMPRES)
;
M ^XTMP(NAMESPACE,"ARG","PUT RESULT")=RESULT
;
Q
;
;POSTS VS PUTS
;
;POST - CREATES A NEW RECORD EVERY TIME, NO IEN (RESOURCE ID?) NEEDED BUT RETURNED AS A SUCCESS VALUE, FILE AND REQUIRED KEY FIELDS NEEDED
;PUT - UPDATES AN EXISTING RECORD, .01 SEARCH STR REQUIRED, EDITABLE FIELDS ALLOWED
;DELETE - DELETE A RECORD - DISCUSSION HOW TO IMPLEMENT
;
;VISTA FILEMAN FILE UPDATE
;K ARG,RESULT D PUTTEST^IBTASDB(.ARG,1) D PUT^IBTASDB(.RESULT,.ARG)
;K RESULT D PUT^IBTASDB(.RESULT,.TESTARG)
PUT(RESULT,ARG) ;EP - EDIT EXISTING RECORD IN FM FILE
N ARRAY,ARGRECORD,EXISTINGIEN,FINDRES,FINDRET,FINDERR,FILENUM,FIELDS,FLAGS
N IEN,IENS,INDEX,PUTFDA,PUTFLAGS,PUTRES,RETNUMBER,SCREEN,TARGET,VALUE
D DTNOLF^DICRW
;INPUT: ARG HAS A PSEUDO FDA STRUCTURE WHERE THE THREE SUBSCRIPTS OF AN FDA ARRAY ARE 'FUSED' INTO ONE SUBSCRIPT
; ARG("FILENUMBER_RECORDNUMBER_FIELDNUMBER")=VALUE
;
;OUTPUT: JSON STATUS STRING
;
;IN A PUT WE NEED THE SPECIAL LOOKUP FIELD. IEN SPECIFIC EDIT IS NOT ALLOWED
;ARG(file_number,unique_rec_number,search_target)=target_string
;ARG(file_number,unique_rec_number,field_number)=NEW VALUE ;IN PUT THE .01 FIELD COULD BE NEW VALUE NOT A SEARCH TARGET
;WARNING: IF THE .01 IS THE SAME IN THE INPUT ARG ARRAY OR CREATES DUPES IN THE FILE
;THE FILE^DIE CALL DOES NOT WARN YOU OR CARE DUPES ARE CREATED.
;THIS CAN CREATE A DUPLICATE RECORD IF YOU ARE NOT CAREFUL
;SET UP PUTFDA TO MAKE THE FILE^DIE CALL
K FINDRES
S FILENUM=0
F S FILENUM=$O(ARG(FILENUM)) Q:'FILENUM D
.S ARGRECORD=""
.F S ARGRECORD=$O(ARG(FILENUM,ARGRECORD)) Q:ARGRECORD="" D
..I $G(ARG(FILENUM,ARGRECORD,.01))="@" D Q
...S FINDRES("0^find_errors",ARGRECORD,"ARG array record")=$G(ARGRECORD)
...S TARGET=$G(ARG(FILENUM,ARGRECORD,.01))
...S TARGET=$S($G(TARGET)=+$G(TARGET):$G(TARGET),1:""""_$G(TARGET)_"""")
...S FINDRES("0^find_errors",ARGRECORD,".01")=$G(TARGET)
...S FINDRES("0^find_errors",ARGRECORD,"error_message")="@ found in .01 field. Use DELETE for deleting records."
..;
..S IENS="" ;NO SUBFILE SEARCH
..S FIELDS="" ;NO FIELDS NEEDED FOR A LOOKUP FOR A FILE^DIE
..;
..K TARGET
..D LKPFLAGS^IBTASDBUTL(.FLAGS,FILENUM,ARGRECORD,.TARGET,.ARG,.FINDRES) ;ANALYZE DD OF FILE AND RETURN APPROPRIATE LOOKUP FLAGS
..;
..; ^DD("KEY","F",364.8,.01,49,1)=""
..S INDEX="" ;NEVER SEEMS TO BE NEEDED WHEN USING FLAGS="M" IN SIMPLE SEARCHES
..S RETNUMBER=3 ;HOW MANY "FOUND' RECORDS TO RETURN. ALLOW THREE SO WE CAN SEE IF POSSIBLE DUPES?
..; WHEN RETNUMBER=1 THE FIRST RECORD FOUND IS RETURNED
..S SCREEN="" ;EQUILVALENT TO DIC("S")
..;
..;S TARGET=$G(ARG(FILENUM,ARGRECORD,.01,"search_target")) ;NOT USING THIS AS A FIELD YET
..S:'$D(TARGET) TARGET=$G(ARG(FILENUM,ARGRECORD,.01))
..;
..I '$D(TARGET) D
...S FINDRES("0^find_errors",ARGRECORD,"ARG array record")=$G(ARGRECORD)
...;S TARGET=$S($G(TARGET)=+$G(TARGET):$G(TARGET),1:""""_$G(TARGET)_"""")
...S FINDRES("0^find_errors",ARGRECORD,".01")=$G(TARGET)
...S FINDRES("0^find_errors",ARGRECORD,"error_message")="ARG search_target not defined or null"
..;
..;CHECK FOR EXISTING ENTRY IN FILE
..K FINDRET,FINDERR
..;
..D FIND^DIC(FILENUM,IENS,FIELDS,FLAGS,.TARGET,RETNUMBER,INDEX,SCREEN,"","FINDRET","FINDERR")
..;
..;THIS IS A FIND^DIC ERROR
..I $D(FINDERR) D Q
...S FINDRES("0^find_errors",ARGRECORD,"ARG array record")=$G(ARGRECORD)
...S TARGET=$G(TARGET,"undefined")
...S TARGET=$S($G(TARGET)=+$G(TARGET):$G(TARGET),1:""""_$G(TARGET)_"""")
...S FINDRES("0^find_errors",ARGRECORD,".01")=$G(TARGET)
...S FINDRES("0^find_errors",ARGRECORD,"error_message")=$G(FINDERR("DIERR",1))_" "_$TR($G(FINDERR("DIERR",1,"TEXT",1)),"""")
..;
..;THIS IS A POSSIBLE DUPLICATE CHECK ERROR FILE^DIE DOESN'T DETECT
..;THIS WILL OCCUR IF THE REQUESTER TRIED TO EDIT A RECORD INTO BEING A DUPE OF AN EXISTING RECORD
..;BEFORE THE CALL OR A DUPE OR ONE THIS CALL ALREADY EDITED.
..;
..I +$G(FINDRET("DILIST",0))>1 D Q
...S FINDRES("0^find_errors",ARGRECORD,"ARG array record")=$G(ARGRECORD)
...S TARGET=$G(TARGET,"undefined")
...S TARGET=$S($G(TARGET)=+$G(TARGET):$G(TARGET),1:""""_$G(TARGET)_"""")
...S FINDRES("0^find_errors",ARGRECORD,".01")=$G(TARGET)
...S FINDRES("0^find_errors",ARGRECORD,"error_message")="ARG Search found multiple entries in "_$G(FILENUM)_", and can't resolve for editing."
..;
..;THE REQUESTER PASSED A .01 VALUE THAT CAN NOT BE FOUND AND THEREFORE CANNOT BE EDITED
..I +$G(FINDRET("DILIST",0))=0 D Q
...S FINDRES("0^find_errors",ARGRECORD,"ARG array record")=$G(ARGRECORD)
...S TARGET=$G(TARGET,"undefined")
...S TARGET=$S($G(TARGET)=+$G(TARGET):$G(TARGET),1:""""_$G(TARGET)_"""")
...S FINDRES("0^find_errors",ARGRECORD,".01")=$G(TARGET)
...S FINDRES("0^find_errors",ARGRECORD,"error_message")="ARG search_target returned nothing for file "_$G(FILENUM)
..;
..S IEN=$G(FINDRET("DILIST",2,1))
..;S ARG(FILENUM,ARGRECORD,.01)=$G(ARG(FILENUM,ARGRECORD,.01,"search_target"))
..;K ARG(FILENUM,ARGRECORD,.01,"search_target")
..M PUTFDA(FILENUM,IEN_",")=ARG(FILENUM,ARGRECORD)
..;
..;ALTHOUGH THE TARGET STRING WAS FOUND WE NEED TO CHECK IF THE .01 FIELD IS LISTED IT CANNOT BE CHANGED TO CAUSE
..;A DUPLICATE
..;Q:$G(PUTFDA(FILENUM,IEN_",",.01))="" ;IF THE SEARCH VALUE WAS FOUND AND THE CALLER WANTS TO EDIT THE .01 FIELD
..;S TARGET=PUTFDA(FILENUM,IEN_",",.01)
..;K FINDERR,FINDRET
..;D FIND^DIC(FILENUM,IENS,FIELDS,FLAGS,TARGET,RETNUMBER,INDEX,SCREEN,,"FINDRET","FINDERR")
..;I +$G(FINDRET("DILIST",0))>0 D Q ;IF NEW VALUE IS ALREADY THERE THEN THIS NEW ONE WILL BE A DUPE
..;.S EXISTINGIEN=FINDRET("DILIST",2,1) ;IEN OF EXISTING RECORD
..;.Q:IEN=EXISTINGIEN
..;.K PUTFDA(FILENUM,IEN_",")
..;.S FINDRES("0^find_errors",ARGRECORD+.5,"ARG array record")=ARGRECORD
..;.S FINDRES("0^find_errors",ARGRECORD+.5,"error_message")="ARG will create duplicate entries in "_FILENUM
..;.;D ENCODE^XLFJSON("FINDRES","RESULT")
..;FROM HERE PLACE IN PUTFDA FOR LATER CALL TO FILE^DIE
..;END PUTFDA CREATION SECTION
..;
..;AT THIS POINT YOU SHOULD HAVE A LIST OF .01 SEARCH VALUES
..;THAT WERE FOUND WITH NO ISSUES AND THEY ARE IN PUTFDA
..I $D(FINDRES),'$D(PUTFDA) Q ;D ENCODE^XLFJSON("FINDRES","RESULT") Q ;NO FIND RESULTS TO EDIT AND ERRORS
..;Q:'$D(PUTFDA)
..;
..S PUTFLAGS="SKET" ;S = SAVE FDA, , K = LOCKING DONE BY API, E = DATA LIKE USER INPUT, T = ALL OR NOTHING
..K PUTERR
..D FILE^DIE(PUTFLAGS,"PUTFDA","PUTERR")
..;
..I $D(PUTERR) D
...;ADDERROR("DIERR",1)=701 ;DATABASE SERVER ERROR CODE
...;ADDERROR("DIERR",1,"TEXT",1)="The value 'FOR ONE' for field FIFTH FIELD in file ZZTPF TEST IBTASDB TEST FILE is not valid."
...;S RESULT(1)=$G(ADDERROR("DIERR",1))_" "_$G(ADDERROR("DIERR",1,"TEXT",1))
...S PUTRES("0^put_errors",ARGRECORD,"ARG array record")=ARGRECORD
...S PUTRES("0^put_errors",ARGRECORD,"error_message")=$G(PUTERR("DIERR",1))_" "_$TR($G(PUTERR("DIERR",1,"TEXT",1)),"""")
...S TARGET=$S($G(PUTFDA(FILENUM,IEN_",",.01))=+$G(TARGET):$G(PUTFDA(FILENUM,IEN_",",.01)),1:""""_$G(PUTFDA(FILENUM,IEN_",",.01))_"""")
...S PUTRES("0^put_errors",ARGRECORD,".01")=$G(TARGET)
..E D
...S PUTRES("1^put_successes",ARGRECORD,"ARG array record")=ARGRECORD
...S PUTRES("1^put_successes",ARGRECORD,"file_number")=FILENUM
...S PUTRES("1^put_successes",ARGRECORD,".01")=$G(PUTFDA(FILENUM,IEN_",",.01))
...S PUTRES("1^put_successes",ARGRECORD,"file_number")=FILENUM
...;
;
M PUTRES=FINDRES
M RESULT=PUTRES
;D JSON(.RESULT,.PUTRES)
;D ENCODE^XLFJSON("PUTRES","RESULT")
;
Q
;
;POST - CREATES A NEW RECORD EVERY TIME, NO IEN (RESOURCE ID) NEEDED (BUT RETURNED AS A SUCCESS VALUE?), FILE AND REQUIRED FIELDS NEEDED
;TPF;EBILL-2515
;
;.S ARG(122000001,"+1,",.01)="NEW VLAUE FOR
;jOHNS' COMMENT:
;ARG("field.1")="data", where field.1 can be whatever you need it to be.
;The 277STAT array, in my opinion, is too verbose. but you can determine
;as you see it. there is a bug in the build of the array in that multiple records
;are not in sequential order, so they are loaded into VistA in the correct order. - technical debt issue
;
;K ARG D POSTTEST^IBTASDBTESTER(.ARG,5) D POST^IBTASDB(.RESULT,.ARG)
;K RESULT D POST^IBTASDB(.RESULT,.TESTARG)
POSTADD(RESULT,ARG) ;EP - CREATE NEW RECORD(S) IN FM FILE
N ARGGREF,ARGRECORD,FILENUM,IENS,JSERR,POSTFDA,POSTERR,POSTIENS,POSTERR,POSTFLAGS,POSTRES,POSTRES,VALUE
D DTNOLF^DICRW
;INPUT: ARG HAS A PSEUDO FDA STRUCTURE WHERE THE THREE SUBSCRIPTS OF AN FDA ARRAY ARE 'FUSED' INTO ONE SUBSCRIPT
; ARG("FILENUMBER_RECORDNUMBER_FIELDNUMBER")=VALUE
;
;OUTPUT: JSON STATUS STRING
;
I '$D(ARG) D Q
.S RESULT("status")="0^ARG array missing"
;
;I FILESECURITY IS ENABLED CHECK TO SEE IF FILENUMBER IS ALLOWED FOR THIS API
;Q:FILENUMBER NOT ALLOWED
;
S POSTFLAGS="ES" ;E = INCOMING DATA EXPECTED LIKE USER INPUT, S = KEEP FDA ARRAY
;
K RESULT,POSTRES
S IENS="+1,"
S FILENUM=$O(ARG(""))
S ARGRECORD=0
F S ARGRECORD=$O(ARG(FILENUM,ARGRECORD)) Q:'ARGRECORD D
.K POSTERR,POSTFDA,POSTIENS
.M POSTFDA(FILENUM,IENS)=ARG(FILENUM,ARGRECORD)
.;
.;WHY IS THIS NOT GIVING ME A DUPE ERROR ON RUNNING THE SAME FDA AGAIN AND AGAIN???
.;POSSIBLE BECAUSE I SET POSTIENS(1) TO GET THE NEW IEN BACK??
.;
.S POSTIENS(1)=""
.;
.D UPDATE^DIE(POSTFLAGS,"POSTFDA","POSTIENS","POSTERR")
.I $D(POSTERR) D
..S POSTRES("0^post_errors",ARGRECORD,"ARG array record")=ARGRECORD
..S VALUE=$G(POSTFDA(364.8,"+1,",.01))
..S VALUE=$S($G(VALUE)=+$G(VALUE):$G(VALUE),1:""""_$G(VALUE)_"""")
..S POSTRES("0^post_errors",ARGRECORD,.01)=$G(VALUE)
..S POSTRES("0^post_errors",ARGRECORD,"error_message")=$G(POSTERR("DIERR",1))_" "_$TR($G(POSTERR("DIERR",1,"TEXT",1)),"""")
.E D
..;B:$G(DUZ)=561 "S+"
..S VALUE=$G(POSTFDA(364.8,"+1,",.01))
..S VALUE=$S($G(VALUE)=+$G(VALUE):$G(VALUE),1:""""_$G(VALUE)_"""")
..S POSTRES("1^post_successes",ARGRECORD,.01)=VALUE
..S POSTRES("1^post_successes",ARGRECORD,"ARG array record")=ARGRECORD
..S POSTRES("1^post_successes",ARGRECORD,"file_number")=FILENUM
..S POSTRES("1^post_successes",ARGRECORD,"newIEN")=POSTIENS(1)
;
M RESULT=POSTRES
;MOVE THIS IS END OF ARG PROCESSES TO INCLUDE ALL ERRORS FOR ALL RECORDS PASSED
;D JSON(.RESULT,.POSTRES)
;D ENCODE^XLFJSON("POSTRES","RESULT","JSERR")
;
;NEW NEEDS TESTING - DO WHAT ON JSON ERROR?
;I $D(JSONERR) D
;.M RESULT=JSERROR
;
Q
;
JSON(RESULT,POSTRES) ;EP
N OLDRESTYPE,RESTYPE,REC,KEY,TEMP
S RESULT="["
S RESTYPE=""
F S RESTYPE=$O(POSTRES(RESTYPE)) Q:RESTYPE="" D
.S OLDRESTYPE=RESTYPE
.;S RESULT=RESULT_"{""status"":"""_RESTYPE_"""},"
.;
.S REC=0
.F S REC=$O(POSTRES(RESTYPE,REC)) Q:REC="" D
..S RESULT=RESULT_"{"
..;
..S KEY=""
..F S KEY=$O(POSTRES(RESTYPE,REC,KEY)) Q:KEY="" D
...;S RESULT=RESULT_""""_KEY_""":"_$S(KEY[("error"):"""",1:"")_POSTRES(RESTYPE,REC,KEY)_$S(KEY[("error"):"""",1:"")_$S(KEY'[("IEN"):",",1:"")
...S RESULT=RESULT_""""_KEY_""":"_$S(KEY[("error"):"""",1:"")_POSTRES(RESTYPE,REC,KEY)_$S(KEY[("error"):"""",1:"")
...I ($O(POSTRES(RESTYPE,REC,KEY))'="") S RESULT=RESULT_","
..I ($O(POSTRES(RESTYPE,REC))'="")!(($O(POSTRES(RESTYPE)))'="") S RESULT=RESULT_"},"
..E S RESULT=RESULT_"}"
S RESULT=RESULT_"]"
S TEMP=RESULT
K RESULT
S RESULT(1)=TEMP
;
Q
;
INC(COUNTER) ;EP - INCREMENT EMAIL COUNTER
S COUNTER=$G(COUNTER)+1
Q COUNTER
;
FINISH(RESULT) ; enclose message in '[ ]' when a Bundle
N X
I $G(RESULT(1))=""!($G(RESULT(1))="{}") S RESULT(1)="[{}]" Q
S RESULT(1)="["_RESULT(1)
S X=$O(RESULT("A"),-1)
S RESULT(X)=RESULT(X)_"]"
Q
;
;EXAMPLE USE OF
;VISTAS1:VISTA>S IBSAVE("PCRiens",1,"ien")=78
;VISTAS1:VISTA>D ENCODE^XLFJSON("IBSAVE","RESULT")
;VISTAS1:VISTA>ZW RESULT
;RESULT(1)="{""PCRiens"":[{""ien"":78}]}"
;VISTAS1:VISTA>D FINISH^IBCEMSRI
;VISTAS1:VISTA>ZW RESULT
;RESULT(1)="[{""PCRiens"":[{""ien"":78}]}]"
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBTASDB 13257 printed Sep 23, 2025@20:03:23 Page 2
IBTASDB ;EDE/TPF - MAIN RTN FOR VTU VISTA TABLE UTILITY
+1 ;;2.0;INTEGRATED BILLING;**742**;;Build 36
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
POST(RESULT,ARG) ;EP - GENERIC CALL FOR IBTASDB
+1 NEW COMPRES,FDAERROR,NOW,POSTFDA,POSTRESULT,PURLOGDT,PUTFDA,PUTRESULT,RTN,X,X1,X2
+2 ;
+3 SET NOW=$$NOW^XLFDT
+4 SET X1=$PIECE(NOW,".")
+5 ;SHOULD BE 30 ON RELEASE. COULD BE A SITE PARAM
SET X2=2
+6 DO C^%DTC
+7 SET PURLOGDT=X
+8 SET RTN=$TEXT(+0)
+9 SET NAMESPACE=RTN_U_NOW_U_"DEBUG DUMP"
+10 SET ^XTMP(NAMESPACE,0)=PURLOGDT_U_$PIECE(NOW,".")_U_"VTU FILE UPDATE LOG"
+11 MERGE ^XTMP(NAMESPACE,"ARG")=ARG
+12 ;
+13 ;CONVERT INCOMING ARG TO POSTFDA AND PUTFDA
DO CONVERTTOFDA^IBTASDBUTL(.ARG,.POSTFDA,.PUTFDA,.FDAERROR)
+14 ;
+15 ;IF AN FDA ERROR THEN CAN'T DO CALLS ANYWAY
IF '$DATA(PUTFDA)
IF '$DATA(POSTFDA)
IF $DATA(FDAERROR)
Begin DoDot:1
+16 MERGE COMPRES=FDAERROR
+17 KILL RESULT
+18 DO JSON(.RESULT,.COMPRES)
+19 MERGE ^XTMP(NAMESPACE,"ARG","PUT RESULT")=RESULT
End DoDot:1
QUIT
+20 ;
+21 KILL RESULT
+22 ;
+23 IF $DATA(POSTFDA)
DO POSTADD(.POSTRESULT,.POSTFDA)
+24 MERGE ^XTMP(NAMESPACE,"ARG","POSTADD RESULT")=RESULT
+25 ;
+26 IF $DATA(PUTFDA)
DO PUT(.PUTRESULT,.PUTFDA)
+27 ;
+28 MERGE COMPRES=POSTRESULT
+29 MERGE COMPRES=PUTRESULT
+30 MERGE COMPRES=FDAERROR
+31 ;
+32 DO JSON(.RESULT,.COMPRES)
+33 ;
+34 MERGE ^XTMP(NAMESPACE,"ARG","PUT RESULT")=RESULT
+35 ;
+36 QUIT
+37 ;
+38 ;POSTS VS PUTS
+39 ;
+40 ;POST - CREATES A NEW RECORD EVERY TIME, NO IEN (RESOURCE ID?) NEEDED BUT RETURNED AS A SUCCESS VALUE, FILE AND REQUIRED KEY FIELDS NEEDED
+41 ;PUT - UPDATES AN EXISTING RECORD, .01 SEARCH STR REQUIRED, EDITABLE FIELDS ALLOWED
+42 ;DELETE - DELETE A RECORD - DISCUSSION HOW TO IMPLEMENT
+43 ;
+44 ;VISTA FILEMAN FILE UPDATE
+45 ;K ARG,RESULT D PUTTEST^IBTASDB(.ARG,1) D PUT^IBTASDB(.RESULT,.ARG)
+46 ;K RESULT D PUT^IBTASDB(.RESULT,.TESTARG)
PUT(RESULT,ARG) ;EP - EDIT EXISTING RECORD IN FM FILE
+1 NEW ARRAY,ARGRECORD,EXISTINGIEN,FINDRES,FINDRET,FINDERR,FILENUM,FIELDS,FLAGS
+2 NEW IEN,IENS,INDEX,PUTFDA,PUTFLAGS,PUTRES,RETNUMBER,SCREEN,TARGET,VALUE
+3 DO DTNOLF^DICRW
+4 ;INPUT: ARG HAS A PSEUDO FDA STRUCTURE WHERE THE THREE SUBSCRIPTS OF AN FDA ARRAY ARE 'FUSED' INTO ONE SUBSCRIPT
+5 ; ARG("FILENUMBER_RECORDNUMBER_FIELDNUMBER")=VALUE
+6 ;
+7 ;OUTPUT: JSON STATUS STRING
+8 ;
+9 ;IN A PUT WE NEED THE SPECIAL LOOKUP FIELD. IEN SPECIFIC EDIT IS NOT ALLOWED
+10 ;ARG(file_number,unique_rec_number,search_target)=target_string
+11 ;ARG(file_number,unique_rec_number,field_number)=NEW VALUE ;IN PUT THE .01 FIELD COULD BE NEW VALUE NOT A SEARCH TARGET
+12 ;WARNING: IF THE .01 IS THE SAME IN THE INPUT ARG ARRAY OR CREATES DUPES IN THE FILE
+13 ;THE FILE^DIE CALL DOES NOT WARN YOU OR CARE DUPES ARE CREATED.
+14 ;THIS CAN CREATE A DUPLICATE RECORD IF YOU ARE NOT CAREFUL
+15 ;SET UP PUTFDA TO MAKE THE FILE^DIE CALL
+16 KILL FINDRES
+17 SET FILENUM=0
+18 FOR
SET FILENUM=$ORDER(ARG(FILENUM))
if 'FILENUM
QUIT
Begin DoDot:1
+19 SET ARGRECORD=""
+20 FOR
SET ARGRECORD=$ORDER(ARG(FILENUM,ARGRECORD))
if ARGRECORD=""
QUIT
Begin DoDot:2
+21 IF $GET(ARG(FILENUM,ARGRECORD,.01))="@"
Begin DoDot:3
+22 SET FINDRES("0^find_errors",ARGRECORD,"ARG array record")=$GET(ARGRECORD)
+23 SET TARGET=$GET(ARG(FILENUM,ARGRECORD,.01))
+24 SET TARGET=$SELECT($GET(TARGET)=+$GET(TARGET):$GET(TARGET),1:""""_$GET(TARGET)_"""")
+25 SET FINDRES("0^find_errors",ARGRECORD,".01")=$GET(TARGET)
+26 SET FINDRES("0^find_errors",ARGRECORD,"error_message")="@ found in .01 field. Use DELETE for deleting records."
End DoDot:3
QUIT
+27 ;
+28 ;NO SUBFILE SEARCH
SET IENS=""
+29 ;NO FIELDS NEEDED FOR A LOOKUP FOR A FILE^DIE
SET FIELDS=""
+30 ;
+31 KILL TARGET
+32 ;ANALYZE DD OF FILE AND RETURN APPROPRIATE LOOKUP FLAGS
DO LKPFLAGS^IBTASDBUTL(.FLAGS,FILENUM,ARGRECORD,.TARGET,.ARG,.FINDRES)
+33 ;
+34 ; ^DD("KEY","F",364.8,.01,49,1)=""
+35 ;NEVER SEEMS TO BE NEEDED WHEN USING FLAGS="M" IN SIMPLE SEARCHES
SET INDEX=""
+36 ;HOW MANY "FOUND' RECORDS TO RETURN. ALLOW THREE SO WE CAN SEE IF POSSIBLE DUPES?
SET RETNUMBER=3
+37 ; WHEN RETNUMBER=1 THE FIRST RECORD FOUND IS RETURNED
+38 ;EQUILVALENT TO DIC("S")
SET SCREEN=""
+39 ;
+40 ;S TARGET=$G(ARG(FILENUM,ARGRECORD,.01,"search_target")) ;NOT USING THIS AS A FIELD YET
+41 if '$DATA(TARGET)
SET TARGET=$GET(ARG(FILENUM,ARGRECORD,.01))
+42 ;
+43 IF '$DATA(TARGET)
Begin DoDot:3
+44 SET FINDRES("0^find_errors",ARGRECORD,"ARG array record")=$GET(ARGRECORD)
+45 ;S TARGET=$S($G(TARGET)=+$G(TARGET):$G(TARGET),1:""""_$G(TARGET)_"""")
+46 SET FINDRES("0^find_errors",ARGRECORD,".01")=$GET(TARGET)
+47 SET FINDRES("0^find_errors",ARGRECORD,"error_message")="ARG search_target not defined or null"
End DoDot:3
+48 ;
+49 ;CHECK FOR EXISTING ENTRY IN FILE
+50 KILL FINDRET,FINDERR
+51 ;
+52 DO FIND^DIC(FILENUM,IENS,FIELDS,FLAGS,.TARGET,RETNUMBER,INDEX,SCREEN,"","FINDRET","FINDERR")
+53 ;
+54 ;THIS IS A FIND^DIC ERROR
+55 IF $DATA(FINDERR)
Begin DoDot:3
+56 SET FINDRES("0^find_errors",ARGRECORD,"ARG array record")=$GET(ARGRECORD)
+57 SET TARGET=$GET(TARGET,"undefined")
+58 SET TARGET=$SELECT($GET(TARGET)=+$GET(TARGET):$GET(TARGET),1:""""_$GET(TARGET)_"""")
+59 SET FINDRES("0^find_errors",ARGRECORD,".01")=$GET(TARGET)
+60 SET FINDRES("0^find_errors",ARGRECORD,"error_message")=$GET(FINDERR("DIERR",1))_" "_$TRANSLATE($GET(FINDERR("DIERR",1,"TEXT",1)),"""")
End DoDot:3
QUIT
+61 ;
+62 ;THIS IS A POSSIBLE DUPLICATE CHECK ERROR FILE^DIE DOESN'T DETECT
+63 ;THIS WILL OCCUR IF THE REQUESTER TRIED TO EDIT A RECORD INTO BEING A DUPE OF AN EXISTING RECORD
+64 ;BEFORE THE CALL OR A DUPE OR ONE THIS CALL ALREADY EDITED.
+65 ;
+66 IF +$GET(FINDRET("DILIST",0))>1
Begin DoDot:3
+67 SET FINDRES("0^find_errors",ARGRECORD,"ARG array record")=$GET(ARGRECORD)
+68 SET TARGET=$GET(TARGET,"undefined")
+69 SET TARGET=$SELECT($GET(TARGET)=+$GET(TARGET):$GET(TARGET),1:""""_$GET(TARGET)_"""")
+70 SET FINDRES("0^find_errors",ARGRECORD,".01")=$GET(TARGET)
+71 SET FINDRES("0^find_errors",ARGRECORD,"error_message")="ARG Search found multiple entries in "_$GET(FILENUM)_", and can't resolve for editing."
End DoDot:3
QUIT
+72 ;
+73 ;THE REQUESTER PASSED A .01 VALUE THAT CAN NOT BE FOUND AND THEREFORE CANNOT BE EDITED
+74 IF +$GET(FINDRET("DILIST",0))=0
Begin DoDot:3
+75 SET FINDRES("0^find_errors",ARGRECORD,"ARG array record")=$GET(ARGRECORD)
+76 SET TARGET=$GET(TARGET,"undefined")
+77 SET TARGET=$SELECT($GET(TARGET)=+$GET(TARGET):$GET(TARGET),1:""""_$GET(TARGET)_"""")
+78 SET FINDRES("0^find_errors",ARGRECORD,".01")=$GET(TARGET)
+79 SET FINDRES("0^find_errors",ARGRECORD,"error_message")="ARG search_target returned nothing for file "_$GET(FILENUM)
End DoDot:3
QUIT
+80 ;
+81 SET IEN=$GET(FINDRET("DILIST",2,1))
+82 ;S ARG(FILENUM,ARGRECORD,.01)=$G(ARG(FILENUM,ARGRECORD,.01,"search_target"))
+83 ;K ARG(FILENUM,ARGRECORD,.01,"search_target")
+84 MERGE PUTFDA(FILENUM,IEN_",")=ARG(FILENUM,ARGRECORD)
+85 ;
+86 ;ALTHOUGH THE TARGET STRING WAS FOUND WE NEED TO CHECK IF THE .01 FIELD IS LISTED IT CANNOT BE CHANGED TO CAUSE
+87 ;A DUPLICATE
+88 ;Q:$G(PUTFDA(FILENUM,IEN_",",.01))="" ;IF THE SEARCH VALUE WAS FOUND AND THE CALLER WANTS TO EDIT THE .01 FIELD
+89 ;S TARGET=PUTFDA(FILENUM,IEN_",",.01)
+90 ;K FINDERR,FINDRET
+91 ;D FIND^DIC(FILENUM,IENS,FIELDS,FLAGS,TARGET,RETNUMBER,INDEX,SCREEN,,"FINDRET","FINDERR")
+92 ;I +$G(FINDRET("DILIST",0))>0 D Q ;IF NEW VALUE IS ALREADY THERE THEN THIS NEW ONE WILL BE A DUPE
+93 ;.S EXISTINGIEN=FINDRET("DILIST",2,1) ;IEN OF EXISTING RECORD
+94 ;.Q:IEN=EXISTINGIEN
+95 ;.K PUTFDA(FILENUM,IEN_",")
+96 ;.S FINDRES("0^find_errors",ARGRECORD+.5,"ARG array record")=ARGRECORD
+97 ;.S FINDRES("0^find_errors",ARGRECORD+.5,"error_message")="ARG will create duplicate entries in "_FILENUM
+98 ;.;D ENCODE^XLFJSON("FINDRES","RESULT")
+99 ;FROM HERE PLACE IN PUTFDA FOR LATER CALL TO FILE^DIE
+100 ;END PUTFDA CREATION SECTION
+101 ;
+102 ;AT THIS POINT YOU SHOULD HAVE A LIST OF .01 SEARCH VALUES
+103 ;THAT WERE FOUND WITH NO ISSUES AND THEY ARE IN PUTFDA
+104 ;D ENCODE^XLFJSON("FINDRES","RESULT") Q ;NO FIND RESULTS TO EDIT AND ERRORS
IF $DATA(FINDRES)
IF '$DATA(PUTFDA)
QUIT
+105 ;Q:'$D(PUTFDA)
+106 ;
+107 ;S = SAVE FDA, , K = LOCKING DONE BY API, E = DATA LIKE USER INPUT, T = ALL OR NOTHING
SET PUTFLAGS="SKET"
+108 KILL PUTERR
+109 DO FILE^DIE(PUTFLAGS,"PUTFDA","PUTERR")
+110 ;
+111 IF $DATA(PUTERR)
Begin DoDot:3
+112 ;ADDERROR("DIERR",1)=701 ;DATABASE SERVER ERROR CODE
+113 ;ADDERROR("DIERR",1,"TEXT",1)="The value 'FOR ONE' for field FIFTH FIELD in file ZZTPF TEST IBTASDB TEST FILE is not valid."
+114 ;S RESULT(1)=$G(ADDERROR("DIERR",1))_" "_$G(ADDERROR("DIERR",1,"TEXT",1))
+115 SET PUTRES("0^put_errors",ARGRECORD,"ARG array record")=ARGRECORD
+116 SET PUTRES("0^put_errors",ARGRECORD,"error_message")=$GET(PUTERR("DIERR",1))_" "_$TRANSLATE($GET(PUTERR("DIERR",1,"TEXT",1)),"""")
+117 SET TARGET=$SELECT($GET(PUTFDA(FILENUM,IEN_",",.01))=+$GET(TARGET):$GET(PUTFDA(FILENUM,IEN_",",.01)),1:""""_$GET(PUTFDA(FILENUM,IEN_",",.01))_"""")
+118 SET PUTRES("0^put_errors",ARGRECORD,".01")=$GET(TARGET)
End DoDot:3
+119 IF '$TEST
Begin DoDot:3
+120 SET PUTRES("1^put_successes",ARGRECORD,"ARG array record")=ARGRECORD
+121 SET PUTRES("1^put_successes",ARGRECORD,"file_number")=FILENUM
+122 SET PUTRES("1^put_successes",ARGRECORD,".01")=$GET(PUTFDA(FILENUM,IEN_",",.01))
+123 SET PUTRES("1^put_successes",ARGRECORD,"file_number")=FILENUM
+124 ;
End DoDot:3
End DoDot:2
End DoDot:1
+125 ;
+126 MERGE PUTRES=FINDRES
+127 MERGE RESULT=PUTRES
+128 ;D JSON(.RESULT,.PUTRES)
+129 ;D ENCODE^XLFJSON("PUTRES","RESULT")
+130 ;
+131 QUIT
+132 ;
+133 ;POST - CREATES A NEW RECORD EVERY TIME, NO IEN (RESOURCE ID) NEEDED (BUT RETURNED AS A SUCCESS VALUE?), FILE AND REQUIRED FIELDS NEEDED
+134 ;TPF;EBILL-2515
+135 ;
+136 ;.S ARG(122000001,"+1,",.01)="NEW VLAUE FOR
+137 ;jOHNS' COMMENT:
+138 ;ARG("field.1")="data", where field.1 can be whatever you need it to be.
+139 ;The 277STAT array, in my opinion, is too verbose. but you can determine
+140 ;as you see it. there is a bug in the build of the array in that multiple records
+141 ;are not in sequential order, so they are loaded into VistA in the correct order. - technical debt issue
+142 ;
+143 ;K ARG D POSTTEST^IBTASDBTESTER(.ARG,5) D POST^IBTASDB(.RESULT,.ARG)
+144 ;K RESULT D POST^IBTASDB(.RESULT,.TESTARG)
POSTADD(RESULT,ARG) ;EP - CREATE NEW RECORD(S) IN FM FILE
+1 NEW ARGGREF,ARGRECORD,FILENUM,IENS,JSERR,POSTFDA,POSTERR,POSTIENS,POSTERR,POSTFLAGS,POSTRES,POSTRES,VALUE
+2 DO DTNOLF^DICRW
+3 ;INPUT: ARG HAS A PSEUDO FDA STRUCTURE WHERE THE THREE SUBSCRIPTS OF AN FDA ARRAY ARE 'FUSED' INTO ONE SUBSCRIPT
+4 ; ARG("FILENUMBER_RECORDNUMBER_FIELDNUMBER")=VALUE
+5 ;
+6 ;OUTPUT: JSON STATUS STRING
+7 ;
+8 IF '$DATA(ARG)
Begin DoDot:1
+9 SET RESULT("status")="0^ARG array missing"
End DoDot:1
QUIT
+10 ;
+11 ;I FILESECURITY IS ENABLED CHECK TO SEE IF FILENUMBER IS ALLOWED FOR THIS API
+12 ;Q:FILENUMBER NOT ALLOWED
+13 ;
+14 ;E = INCOMING DATA EXPECTED LIKE USER INPUT, S = KEEP FDA ARRAY
SET POSTFLAGS="ES"
+15 ;
+16 KILL RESULT,POSTRES
+17 SET IENS="+1,"
+18 SET FILENUM=$ORDER(ARG(""))
+19 SET ARGRECORD=0
+20 FOR
SET ARGRECORD=$ORDER(ARG(FILENUM,ARGRECORD))
if 'ARGRECORD
QUIT
Begin DoDot:1
+21 KILL POSTERR,POSTFDA,POSTIENS
+22 MERGE POSTFDA(FILENUM,IENS)=ARG(FILENUM,ARGRECORD)
+23 ;
+24 ;WHY IS THIS NOT GIVING ME A DUPE ERROR ON RUNNING THE SAME FDA AGAIN AND AGAIN???
+25 ;POSSIBLE BECAUSE I SET POSTIENS(1) TO GET THE NEW IEN BACK??
+26 ;
+27 SET POSTIENS(1)=""
+28 ;
+29 DO UPDATE^DIE(POSTFLAGS,"POSTFDA","POSTIENS","POSTERR")
+30 IF $DATA(POSTERR)
Begin DoDot:2
+31 SET POSTRES("0^post_errors",ARGRECORD,"ARG array record")=ARGRECORD
+32 SET VALUE=$GET(POSTFDA(364.8,"+1,",.01))
+33 SET VALUE=$SELECT($GET(VALUE)=+$GET(VALUE):$GET(VALUE),1:""""_$GET(VALUE)_"""")
+34 SET POSTRES("0^post_errors",ARGRECORD,.01)=$GET(VALUE)
+35 SET POSTRES("0^post_errors",ARGRECORD,"error_message")=$GET(POSTERR("DIERR",1))_" "_$TRANSLATE($GET(POSTERR("DIERR",1,"TEXT",1)),"""")
End DoDot:2
+36 IF '$TEST
Begin DoDot:2
+37 ;B:$G(DUZ)=561 "S+"
+38 SET VALUE=$GET(POSTFDA(364.8,"+1,",.01))
+39 SET VALUE=$SELECT($GET(VALUE)=+$GET(VALUE):$GET(VALUE),1:""""_$GET(VALUE)_"""")
+40 SET POSTRES("1^post_successes",ARGRECORD,.01)=VALUE
+41 SET POSTRES("1^post_successes",ARGRECORD,"ARG array record")=ARGRECORD
+42 SET POSTRES("1^post_successes",ARGRECORD,"file_number")=FILENUM
+43 SET POSTRES("1^post_successes",ARGRECORD,"newIEN")=POSTIENS(1)
End DoDot:2
End DoDot:1
+44 ;
+45 MERGE RESULT=POSTRES
+46 ;MOVE THIS IS END OF ARG PROCESSES TO INCLUDE ALL ERRORS FOR ALL RECORDS PASSED
+47 ;D JSON(.RESULT,.POSTRES)
+48 ;D ENCODE^XLFJSON("POSTRES","RESULT","JSERR")
+49 ;
+50 ;NEW NEEDS TESTING - DO WHAT ON JSON ERROR?
+51 ;I $D(JSONERR) D
+52 ;.M RESULT=JSERROR
+53 ;
+54 QUIT
+55 ;
JSON(RESULT,POSTRES) ;EP
+1 NEW OLDRESTYPE,RESTYPE,REC,KEY,TEMP
+2 SET RESULT="["
+3 SET RESTYPE=""
+4 FOR
SET RESTYPE=$ORDER(POSTRES(RESTYPE))
if RESTYPE=""
QUIT
Begin DoDot:1
+5 SET OLDRESTYPE=RESTYPE
+6 ;S RESULT=RESULT_"{""status"":"""_RESTYPE_"""},"
+7 ;
+8 SET REC=0
+9 FOR
SET REC=$ORDER(POSTRES(RESTYPE,REC))
if REC=""
QUIT
Begin DoDot:2
+10 SET RESULT=RESULT_"{"
+11 ;
+12 SET KEY=""
+13 FOR
SET KEY=$ORDER(POSTRES(RESTYPE,REC,KEY))
if KEY=""
QUIT
Begin DoDot:3
+14 ;S RESULT=RESULT_""""_KEY_""":"_$S(KEY[("error"):"""",1:"")_POSTRES(RESTYPE,REC,KEY)_$S(KEY[("error"):"""",1:"")_$S(KEY'[("IEN"):",",1:"")
+15 SET RESULT=RESULT_""""_KEY_""":"_$SELECT(KEY[("error"):"""",1:"")_POSTRES(RESTYPE,REC,KEY)_$SELECT(KEY[("error"):"""",1:"")
+16 IF ($ORDER(POSTRES(RESTYPE,REC,KEY))'="")
SET RESULT=RESULT_","
End DoDot:3
+17 IF ($ORDER(POSTRES(RESTYPE,REC))'="")!(($ORDER(POSTRES(RESTYPE)))'="")
SET RESULT=RESULT_"},"
+18 IF '$TEST
SET RESULT=RESULT_"}"
End DoDot:2
End DoDot:1
+19 SET RESULT=RESULT_"]"
+20 SET TEMP=RESULT
+21 KILL RESULT
+22 SET RESULT(1)=TEMP
+23 ;
+24 QUIT
+25 ;
INC(COUNTER) ;EP - INCREMENT EMAIL COUNTER
+1 SET COUNTER=$GET(COUNTER)+1
+2 QUIT COUNTER
+3 ;
FINISH(RESULT) ; enclose message in '[ ]' when a Bundle
+1 NEW X
+2 IF $GET(RESULT(1))=""!($GET(RESULT(1))="{}")
SET RESULT(1)="[{}]"
QUIT
+3 SET RESULT(1)="["_RESULT(1)
+4 SET X=$ORDER(RESULT("A"),-1)
+5 SET RESULT(X)=RESULT(X)_"]"
+6 QUIT
+7 ;
+8 ;EXAMPLE USE OF
+9 ;VISTAS1:VISTA>S IBSAVE("PCRiens",1,"ien")=78
+10 ;VISTAS1:VISTA>D ENCODE^XLFJSON("IBSAVE","RESULT")
+11 ;VISTAS1:VISTA>ZW RESULT
+12 ;RESULT(1)="{""PCRiens"":[{""ien"":78}]}"
+13 ;VISTAS1:VISTA>D FINISH^IBCEMSRI
+14 ;VISTAS1:VISTA>ZW RESULT
+15 ;RESULT(1)="[{""PCRiens"":[{""ien"":78}]}]"
