SCAPMC20 ;ALB/REW - Team APIs:APPTTM ; 20 Mar 1996
;;5.3;Scheduling;**41**;AUG 13, 1993
;;1.0
ACOUTPT(DFN,SCFIELDA,SCERR) ;add/edit a record in OUTPATIENT PROFILE #404.41
; input:
; DFN = pointer to PATIENT file (#2)
; SCFIELDA= array of additional fields to be added
; SCERR = array NAME to store error messages.
; [ex. ^TMP("ORXX",$J)]
;
; Output:
; Returned = ok?^404.41 ien^new?
; SCERR() = Array of DIALOG file messages(errors) .
; Foramt:
; Subscript: Sequential # from 1 to n
; Piece Description
; 1 IEN of DIALOG file
N SCEXIST
N SCESEQ,SCPARM,SCIEN,SC,SCFLD
G:'$$OKDATA APTTMQ ;check/setup variables
S SCEXIST=$D(^SCPT(404.41,DFN,0))#2
IF SCEXIST D
.IF $D(SCFIELDA) D
..S SCFLD=0
..F S SCFLD=$O(@SCFIELDA@(SCFLD)) Q:'SCFLD D
...S SC($J,404.41,(+DFN)_",",SCFLD)=@SCFIELDA@(SCFLD)
.D FILE^DIE("E","SC($J)",SCERR)
ELSE D
.S SCIEN(1)=DFN
.S SC($J,404.41,"+1,",.01)="`"_DFN
.IF $D(SCFIELDA) D
..S SCFLD=0
..F S SCFLD=$O(@SCFIELDA@(SCFLD)) Q:'SCFLD D
...S SC($J,404.41,"+1,",SCFLD)=@SCFIELDA@(SCFLD)
.D UPDATE^DIE("E","SC($J)","SCIEN",SCERR)
.IF $D(@SCERR)!($G(SCIEN(1))'=DFN) S @SCERR=1 K SCIEN
.ELSE D
..S SCEXIST=0
APTTMQ Q '$D(@SCERR@(0))_U_+$G(DFN)_U_'$G(SCEXIST)
;
OKDATA() ;setup/check variables
N SCOK
S SCOK=1
D INIT^SCAPMCU1(.SCOK)
IF '$D(^DPT(DFN,0)) D S SCOK=0
. S SCPARM("PATIENT")=DFN
. D ERR^SCAPMCU1(SCESEQ,4045101,.SCPARM,"",.SCERR)
Q SCOK
;
MAKEMANY(DFNA,SCOLDASS,SCBADASS,SCNEWASS) ;Not supported for use by PCMM Only
; DFNA - DFN ARRAY
; SCOLDASS - Subset of DFNA that were previously assigned
; SCBADASS - Subset of DFNA that could not be assigned
; SCNEWASS - Subset of DFNA that were newly assigned
; Return: total^new^old^bad
; Note: No input error checking!!
N DFN,SCX,SCOUTFLD,SCBADOUT,SCBADCNT,SCNEWCND,SCOLDCNT
S (SCBADCNT,SCNEWCNT,SCOLDCNT)=0
S DFN=0
F S DFN=$O(@DFNA@(DFN)) Q:'DFN D
.S SCOUTFLD(.04)=1
.S SCX=$$ACOUTPT(DFN,"SCOUTFLD","SCBADOUT")
.IF 'SCX D
..S @SCBADASS@(DFN)=""
..S SCBADCNT=SCBADCNT+1
.ELSE D
..IF $P(SCX,U,3) D
...S @SCNEWASS@(DFN)=""
...S SCNEWCNT=SCNEWCNT+1
..ELSE D
...S @SCOLDASS@(DFN)=""
...S SCOLDCNT=SCOLDCNT+1
Q (SCOLDCNT+SCNEWCNT)_U_SCNEWCNT_U_SCOLDCNT_U_SCBADCNT
;
PTPCNOTM(SCOUTA,SCDATE) ;Not Supported For Use by PCMM Only
; SCOUTA - Output array of DFNs that are PC but no Team Now
N DFN,SCPC
S DFN=0
F S DFN=$O(^SCPT(404.41,"APC",DFN)) Q:'DFN S SCPC=$O(^(DFN)) Q:'SCPC D
.Q:$D(^TMP("SCMC",$J,"EXCLUDE PT","SCPTA",+DFN))
.S:'$$GETPCTM^SCAPMCU2(DFN,SCDATE,1) @SCOUTA@(DFN)=DFN_U_$P($G(^DPT(DFN,0)),U,1)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCAPMC20 2739 printed Nov 22, 2024@17:47:52 Page 2
SCAPMC20 ;ALB/REW - Team APIs:APPTTM ; 20 Mar 1996
+1 ;;5.3;Scheduling;**41**;AUG 13, 1993
+2 ;;1.0
ACOUTPT(DFN,SCFIELDA,SCERR) ;add/edit a record in OUTPATIENT PROFILE #404.41
+1 ; input:
+2 ; DFN = pointer to PATIENT file (#2)
+3 ; SCFIELDA= array of additional fields to be added
+4 ; SCERR = array NAME to store error messages.
+5 ; [ex. ^TMP("ORXX",$J)]
+6 ;
+7 ; Output:
+8 ; Returned = ok?^404.41 ien^new?
+9 ; SCERR() = Array of DIALOG file messages(errors) .
+10 ; Foramt:
+11 ; Subscript: Sequential # from 1 to n
+12 ; Piece Description
+13 ; 1 IEN of DIALOG file
+14 NEW SCEXIST
+15 NEW SCESEQ,SCPARM,SCIEN,SC,SCFLD
+16 ;check/setup variables
if '$$OKDATA
GOTO APTTMQ
+17 SET SCEXIST=$DATA(^SCPT(404.41,DFN,0))#2
+18 IF SCEXIST
Begin DoDot:1
+19 IF $DATA(SCFIELDA)
Begin DoDot:2
+20 SET SCFLD=0
+21 FOR
SET SCFLD=$ORDER(@SCFIELDA@(SCFLD))
if 'SCFLD
QUIT
Begin DoDot:3
+22 SET SC($JOB,404.41,(+DFN)_",",SCFLD)=@SCFIELDA@(SCFLD)
End DoDot:3
End DoDot:2
+23 DO FILE^DIE("E","SC($J)",SCERR)
End DoDot:1
+24 IF '$TEST
Begin DoDot:1
+25 SET SCIEN(1)=DFN
+26 SET SC($JOB,404.41,"+1,",.01)="`"_DFN
+27 IF $DATA(SCFIELDA)
Begin DoDot:2
+28 SET SCFLD=0
+29 FOR
SET SCFLD=$ORDER(@SCFIELDA@(SCFLD))
if 'SCFLD
QUIT
Begin DoDot:3
+30 SET SC($JOB,404.41,"+1,",SCFLD)=@SCFIELDA@(SCFLD)
End DoDot:3
End DoDot:2
+31 DO UPDATE^DIE("E","SC($J)","SCIEN",SCERR)
+32 IF $DATA(@SCERR)!($GET(SCIEN(1))'=DFN)
SET @SCERR=1
KILL SCIEN
+33 IF '$TEST
Begin DoDot:2
+34 SET SCEXIST=0
End DoDot:2
End DoDot:1
APTTMQ QUIT '$DATA(@SCERR@(0))_U_+$GET(DFN)_U_'$GET(SCEXIST)
+1 ;
OKDATA() ;setup/check variables
+1 NEW SCOK
+2 SET SCOK=1
+3 DO INIT^SCAPMCU1(.SCOK)
+4 IF '$DATA(^DPT(DFN,0))
Begin DoDot:1
+5 SET SCPARM("PATIENT")=DFN
+6 DO ERR^SCAPMCU1(SCESEQ,4045101,.SCPARM,"",.SCERR)
End DoDot:1
SET SCOK=0
+7 QUIT SCOK
+8 ;
MAKEMANY(DFNA,SCOLDASS,SCBADASS,SCNEWASS) ;Not supported for use by PCMM Only
+1 ; DFNA - DFN ARRAY
+2 ; SCOLDASS - Subset of DFNA that were previously assigned
+3 ; SCBADASS - Subset of DFNA that could not be assigned
+4 ; SCNEWASS - Subset of DFNA that were newly assigned
+5 ; Return: total^new^old^bad
+6 ; Note: No input error checking!!
+7 NEW DFN,SCX,SCOUTFLD,SCBADOUT,SCBADCNT,SCNEWCND,SCOLDCNT
+8 SET (SCBADCNT,SCNEWCNT,SCOLDCNT)=0
+9 SET DFN=0
+10 FOR
SET DFN=$ORDER(@DFNA@(DFN))
if 'DFN
QUIT
Begin DoDot:1
+11 SET SCOUTFLD(.04)=1
+12 SET SCX=$$ACOUTPT(DFN,"SCOUTFLD","SCBADOUT")
+13 IF 'SCX
Begin DoDot:2
+14 SET @SCBADASS@(DFN)=""
+15 SET SCBADCNT=SCBADCNT+1
End DoDot:2
+16 IF '$TEST
Begin DoDot:2
+17 IF $PIECE(SCX,U,3)
Begin DoDot:3
+18 SET @SCNEWASS@(DFN)=""
+19 SET SCNEWCNT=SCNEWCNT+1
End DoDot:3
+20 IF '$TEST
Begin DoDot:3
+21 SET @SCOLDASS@(DFN)=""
+22 SET SCOLDCNT=SCOLDCNT+1
End DoDot:3
End DoDot:2
End DoDot:1
+23 QUIT (SCOLDCNT+SCNEWCNT)_U_SCNEWCNT_U_SCOLDCNT_U_SCBADCNT
+24 ;
PTPCNOTM(SCOUTA,SCDATE) ;Not Supported For Use by PCMM Only
+1 ; SCOUTA - Output array of DFNs that are PC but no Team Now
+2 NEW DFN,SCPC
+3 SET DFN=0
+4 FOR
SET DFN=$ORDER(^SCPT(404.41,"APC",DFN))
if 'DFN
QUIT
SET SCPC=$ORDER(^(DFN))
if 'SCPC
QUIT
Begin DoDot:1
+5 if $DATA(^TMP("SCMC",$JOB,"EXCLUDE PT","SCPTA",+DFN))
QUIT
+6 if '$$GETPCTM^SCAPMCU2(DFN,SCDATE,1)
SET @SCOUTA@(DFN)=DFN_U_$PIECE($GET(^DPT(DFN,0)),U,1)
End DoDot:1
+7 QUIT
