SDES2CREATESNAPS ;ALB/BLB - CREATE SPECIAL NEEDS AND PREFERENCES OCT 27,2023
;;5.3;Scheduling;**864,877**;Aug 13, 1993;Build 14
;;Per VHA Directive 6402, this routine should not be modified
;
Q
;
CREATENEEDSPREFS(JSON,SDCONTEXT,NEEDSPREFS) ;
N ERRORS,RETURN,VALRETURN
;
D VALFILEIEN^SDES2VALUTIL(.VALRETURN,.ERRORS,2,$G(NEEDSPREFS("PATIENT DFN")),1,,1,2)
D VALCONTEXT^SDES2VALCONTEXT(.ERRORS,.SDCONTEXT)
I $D(ERRORS) S ERRORS("SpecialNeedsAndPreferences",1)="" M RETURN=ERRORS D BUILDJSON^SDES2JSON(.JSON,.RETURN) Q
;
S NEEDSPREFS("USER DUZ")=SDCONTEXT("USER DUZ")
S NEEDSPREFS("IEN")=0,NEEDSPREFS("IEN")=$O(^SDEC(409.845,"B",NEEDSPREFS("PATIENT DFN"),NEEDSPREFS("IEN")))
D VALIDATENEEDPREF(.ERRORS,.NEEDSPREFS)
I $D(ERRORS) S ERRORS("SpecialNeedsAndPreferences",1)="" M RETURN=ERRORS D BUILDJSON^SDES2JSON(.JSON,.RETURN) Q
;
D BUILD(.NEEDSPREFS,.RETURN)
D BUILDJSON^SDES2JSON(.JSON,.RETURN) Q
Q
;
BUILD(NEEDSPREFS,RETURN) ;
N PATIENTFDA,PATIENTFDAERR,NEEDSPREFSFDAERR,RETURNIEN,COUNT,IENS
;
; create top level patient record
I '$G(NEEDSPREFS("IEN")) D
.S PATIENTFDA(409.845,"+1,",.01)=NEEDSPREFS("PATIENT DFN")
.D UPDATE^DIE("","PATIENTFDA","RETURNIEN","PATIENTFDAERR") K PATIENTFDA
.S NEEDSPREFS("IEN")=$G(RETURNIEN(1))
;
; create sub level pref records
S COUNT=0
F S COUNT=$O(NEEDSPREFS("SPECIAL NEEDS AND PREFERENCES",COUNT)) Q:'COUNT D
.;
.N NEEDSPREFSFDA,REMARK,RETURNPREFIEN
.S IENS="+1,"_NEEDSPREFS("IEN")_","
.S NEEDSPREFSFDA(409.8451,IENS,.01)=$G(NEEDSPREFS("SPECIAL NEEDS AND PREFERENCES",COUNT))
.S NEEDSPREFSFDA(409.8451,IENS,2)=$$NOW^XLFDT
.S NEEDSPREFSFDA(409.8451,IENS,3)=NEEDSPREFS("USER DUZ")
.D UPDATE^DIE(,"NEEDSPREFSFDA","RETURNPREFIEN","NEEDSPREFSFDAERR") K NEEDSPREFSFDA
.S RETURN("SpecialNeedsAndPreferences",COUNT,"Name")=$$SOCINT2EXT^SDESUTIL(409.8451,.01,NEEDSPREFS("SPECIAL NEEDS AND PREFERENCES",COUNT))
.;
.; create sub level word processing entry
.I $D(NEEDSPREFS("SPECIAL NEEDS AND PREFERENCES",COUNT,"REMARK")) D
..S REMARK(COUNT)=NEEDSPREFS("SPECIAL NEEDS AND PREFERENCES",COUNT,"REMARK")
..D WP^DIE(409.8451,RETURNPREFIEN(1)_","_NEEDSPREFS("IEN")_",",6,,"REMARK")
Q
;
VALIDATENEEDPREF(ERRORS,NEEDSPREFS) ;
N COUNT,DUP,INTERNALPREF
I '$L($G(NEEDSPREFS("SPECIAL NEEDS AND PREFERENCES",1))) D ERRLOG^SDESJSON(.ERRORS,438) Q
S COUNT=0,DUP=0
F S COUNT=$O(NEEDSPREFS("SPECIAL NEEDS AND PREFERENCES",COUNT)) Q:'COUNT!(DUP=1) D
.D VALSETOFCODES(.ERRORS,NEEDSPREFS("SPECIAL NEEDS AND PREFERENCES",COUNT),409.8451,.01,"Invalid special need or preference") I $D(ERRORS) S DUP=1 Q
.I $G(NEEDSPREFS("SPECIAL NEEDS AND PREFERENCES",COUNT))="" D ERRLOG^SDESJSON(.ERRORS,438) S DUP=1 Q
.I $G(NEEDSPREFS("IEN")) D
..S INTERNALPREF=$$SOCEXT2INT^SDESUTIL(409.8451,.01,NEEDSPREFS("SPECIAL NEEDS AND PREFERENCES",COUNT))
..I $D(^SDEC(409.845,NEEDSPREFS("IEN"),1,"B",INTERNALPREF)) D ERRLOG^SDESJSON(.ERRORS,435) S DUP=1 Q
.S NEEDSPREFS("SPECIAL NEEDS AND PREFERENCES",COUNT)=$$SOCEXT2INT^SDESUTIL(409.8451,.01,NEEDSPREFS("SPECIAL NEEDS AND PREFERENCES",COUNT))
Q
;
VALSETOFCODES(ERRORS,VALUE,FILE,FLD,TEXT) ;
N RESULTS,CONT,CODE,INTCODE,FOUND,RESULTS,ITEM,EXTCODE
I VALUE="" D ERRLOG^SDESJSON(.ERRORS,52,"Missing set of codes value: "_TEXT_".") Q
D FIELD^DID(FILE,FLD,"","SET OF CODES","RESULTS")
S FOUND=0
F ITEM=1:1:$L(RESULTS("SET OF CODES"),";") D Q:FOUND
.S CODE=$P(RESULTS("SET OF CODES"),";",ITEM) Q:'$L(CODE)
.S INTCODE=$P(CODE,":"),EXTCODE=$P(CODE,":",2)
.I VALUE=EXTCODE S FOUND=1 Q
I 'FOUND D ERRLOG^SDESJSON(.ERRORS,52,"Invalid set of codes value: "_TEXT_": '"_VALUE_"'.")
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDES2CREATESNAPS 3651 printed Sep 23, 2025@20:30:04 Page 2
SDES2CREATESNAPS ;ALB/BLB - CREATE SPECIAL NEEDS AND PREFERENCES OCT 27,2023
+1 ;;5.3;Scheduling;**864,877**;Aug 13, 1993;Build 14
+2 ;;Per VHA Directive 6402, this routine should not be modified
+3 ;
+4 QUIT
+5 ;
CREATENEEDSPREFS(JSON,SDCONTEXT,NEEDSPREFS) ;
+1 NEW ERRORS,RETURN,VALRETURN
+2 ;
+3 DO VALFILEIEN^SDES2VALUTIL(.VALRETURN,.ERRORS,2,$GET(NEEDSPREFS("PATIENT DFN")),1,,1,2)
+4 DO VALCONTEXT^SDES2VALCONTEXT(.ERRORS,.SDCONTEXT)
+5 IF $DATA(ERRORS)
SET ERRORS("SpecialNeedsAndPreferences",1)=""
MERGE RETURN=ERRORS
DO BUILDJSON^SDES2JSON(.JSON,.RETURN)
QUIT
+6 ;
+7 SET NEEDSPREFS("USER DUZ")=SDCONTEXT("USER DUZ")
+8 SET NEEDSPREFS("IEN")=0
SET NEEDSPREFS("IEN")=$ORDER(^SDEC(409.845,"B",NEEDSPREFS("PATIENT DFN"),NEEDSPREFS("IEN")))
+9 DO VALIDATENEEDPREF(.ERRORS,.NEEDSPREFS)
+10 IF $DATA(ERRORS)
SET ERRORS("SpecialNeedsAndPreferences",1)=""
MERGE RETURN=ERRORS
DO BUILDJSON^SDES2JSON(.JSON,.RETURN)
QUIT
+11 ;
+12 DO BUILD(.NEEDSPREFS,.RETURN)
+13 DO BUILDJSON^SDES2JSON(.JSON,.RETURN)
QUIT
+14 QUIT
+15 ;
BUILD(NEEDSPREFS,RETURN) ;
+1 NEW PATIENTFDA,PATIENTFDAERR,NEEDSPREFSFDAERR,RETURNIEN,COUNT,IENS
+2 ;
+3 ; create top level patient record
+4 IF '$GET(NEEDSPREFS("IEN"))
Begin DoDot:1
+5 SET PATIENTFDA(409.845,"+1,",.01)=NEEDSPREFS("PATIENT DFN")
+6 DO UPDATE^DIE("","PATIENTFDA","RETURNIEN","PATIENTFDAERR")
KILL PATIENTFDA
+7 SET NEEDSPREFS("IEN")=$GET(RETURNIEN(1))
End DoDot:1
+8 ;
+9 ; create sub level pref records
+10 SET COUNT=0
+11 FOR
SET COUNT=$ORDER(NEEDSPREFS("SPECIAL NEEDS AND PREFERENCES",COUNT))
if 'COUNT
QUIT
Begin DoDot:1
+12 ;
+13 NEW NEEDSPREFSFDA,REMARK,RETURNPREFIEN
+14 SET IENS="+1,"_NEEDSPREFS("IEN")_","
+15 SET NEEDSPREFSFDA(409.8451,IENS,.01)=$GET(NEEDSPREFS("SPECIAL NEEDS AND PREFERENCES",COUNT))
+16 SET NEEDSPREFSFDA(409.8451,IENS,2)=$$NOW^XLFDT
+17 SET NEEDSPREFSFDA(409.8451,IENS,3)=NEEDSPREFS("USER DUZ")
+18 DO UPDATE^DIE(,"NEEDSPREFSFDA","RETURNPREFIEN","NEEDSPREFSFDAERR")
KILL NEEDSPREFSFDA
+19 SET RETURN("SpecialNeedsAndPreferences",COUNT,"Name")=$$SOCINT2EXT^SDESUTIL(409.8451,.01,NEEDSPREFS("SPECIAL NEEDS AND PREFERENCES",COUNT))
+20 ;
+21 ; create sub level word processing entry
+22 IF $DATA(NEEDSPREFS("SPECIAL NEEDS AND PREFERENCES",COUNT,"REMARK"))
Begin DoDot:2
+23 SET REMARK(COUNT)=NEEDSPREFS("SPECIAL NEEDS AND PREFERENCES",COUNT,"REMARK")
+24 DO WP^DIE(409.8451,RETURNPREFIEN(1)_","_NEEDSPREFS("IEN")_",",6,,"REMARK")
End DoDot:2
End DoDot:1
+25 QUIT
+26 ;
VALIDATENEEDPREF(ERRORS,NEEDSPREFS) ;
+1 NEW COUNT,DUP,INTERNALPREF
+2 IF '$LENGTH($GET(NEEDSPREFS("SPECIAL NEEDS AND PREFERENCES",1)))
DO ERRLOG^SDESJSON(.ERRORS,438)
QUIT
+3 SET COUNT=0
SET DUP=0
+4 FOR
SET COUNT=$ORDER(NEEDSPREFS("SPECIAL NEEDS AND PREFERENCES",COUNT))
if 'COUNT!(DUP=1)
QUIT
Begin DoDot:1
+5 DO VALSETOFCODES(.ERRORS,NEEDSPREFS("SPECIAL NEEDS AND PREFERENCES",COUNT),409.8451,.01,"Invalid special need or preference")
IF $DATA(ERRORS)
SET DUP=1
QUIT
+6 IF $GET(NEEDSPREFS("SPECIAL NEEDS AND PREFERENCES",COUNT))=""
DO ERRLOG^SDESJSON(.ERRORS,438)
SET DUP=1
QUIT
+7 IF $GET(NEEDSPREFS("IEN"))
Begin DoDot:2
+8 SET INTERNALPREF=$$SOCEXT2INT^SDESUTIL(409.8451,.01,NEEDSPREFS("SPECIAL NEEDS AND PREFERENCES",COUNT))
+9 IF $DATA(^SDEC(409.845,NEEDSPREFS("IEN"),1,"B",INTERNALPREF))
DO ERRLOG^SDESJSON(.ERRORS,435)
SET DUP=1
QUIT
End DoDot:2
+10 SET NEEDSPREFS("SPECIAL NEEDS AND PREFERENCES",COUNT)=$$SOCEXT2INT^SDESUTIL(409.8451,.01,NEEDSPREFS("SPECIAL NEEDS AND PREFERENCES",COUNT))
End DoDot:1
+11 QUIT
+12 ;
VALSETOFCODES(ERRORS,VALUE,FILE,FLD,TEXT) ;
+1 NEW RESULTS,CONT,CODE,INTCODE,FOUND,RESULTS,ITEM,EXTCODE
+2 IF VALUE=""
DO ERRLOG^SDESJSON(.ERRORS,52,"Missing set of codes value: "_TEXT_".")
QUIT
+3 DO FIELD^DID(FILE,FLD,"","SET OF CODES","RESULTS")
+4 SET FOUND=0
+5 FOR ITEM=1:1:$LENGTH(RESULTS("SET OF CODES"),";")
Begin DoDot:1
+6 SET CODE=$PIECE(RESULTS("SET OF CODES"),";",ITEM)
if '$LENGTH(CODE)
QUIT
+7 SET INTCODE=$PIECE(CODE,":")
SET EXTCODE=$PIECE(CODE,":",2)
+8 IF VALUE=EXTCODE
SET FOUND=1
QUIT
End DoDot:1
if FOUND
QUIT
+9 IF 'FOUND
DO ERRLOG^SDESJSON(.ERRORS,52,"Invalid set of codes value: "_TEXT_": '"_VALUE_"'.")
+10 QUIT
+11 ;
