SCMCCV5 ;ALB/JAM;Allow edits of invalid .03 field in 404.52;12/1/99@1055
;;5.3;Scheduling;**204,297**;DEC 01, 1999
;
EDIT ;Entry point for cnahes to .03 field in file 404.52
N SCEND
D HDR(0)
S SCEND=0
F D PROCESS I SCEND Q
K DIE,^TMP("PCMM PRACTITIONER",$J),DTOUT,DUOUT,DIROUT,DR,DA,X,Y
Q
;
PROCESS ;Get list of invalid .03 field in file 404.52, select and then edit
N SCIEN,FND
K ^TMP("PCMM PRACTITIONER",$J)
S FND=$$LST()
I 'FND W "No Entries found" S SCEND=1 Q
;select a valid IEN to edit
S SCIEN=$$GETIEN() I 'SCIEN S SCEND=1 Q
;edit .03 field
REP D TPHIS(SCIEN)
K DA,DR,DIE S DIE="^SCTM(404.52,",DA=SCIEN
S DR=".03Practitioner" D ^DIE K DR
I $D(DTOUT)!($D(DUOUT)) S SCEND=1 Q
I $G(Y)<0 Q
;verify practitioner response
K DA,DIR,DIROUT,DIRUT,DTOUT,DUOUT
S DIR(0)="Y",DIR("A")=" ...OK",DIR("B")="Yes"
S DIR("?")="Enter Yes or <RT> to accept or No to change response"
D ^DIR K DIR I Y Q
I $D(DTOUT)!$D(DUOUT)!($D(DIROUT)) Q
G REP
Q
;
GETIEN() ;Select IEN from FILE 404.52
N DIR,X,Y
S DIR("A")="Select IEN",DIR("?")="^D LSTIEN^SCMCCV5"
S DIR(0)="FO^^K:'$D(^TMP(""PCMM PRACTITIONER"",$J,X)) X"
D ^DIR I $D(DIRUT) Q 0
D DSP(X)
Q X
;
LSTIEN ;Display a list of .03 entries stored in ^TMP("PCMM PRACTITIONER",$J
N IEN,SCSTP
S (IEN,SCSTP)=0
D HDR(1)
F S IEN=$O(^TMP("PCMM PRACTITIONER",$J,IEN)) Q:'IEN D I SCSTP Q
. I ($Y+3>IOSL) D I 'Y S SCSTP=1 Q
. . S DIR(0)="E",DIR("A")="Enter RETURN to continue or '^' to exit"
. . D ^DIR D:Y HDR(1)
. D DSP(IEN)
I 'SCSTP W !,?20,"To Edit, enter an IEN number from the displayed list"
Q
;
HDR(FL) ;Print header for list of invalid entries in file 404.52
W @IOF
W !,?23,$S(FL:"LIST OF",1:"EDITING")_" INVALID PRACTITIONER ENTRY",!!
I FL D
. W ?20,"IEN",?27,"Effective Date",?44,"Team",?68,"Status",!
. W ?20,"---",?27,"--------------",?44,"----",?68,"------",!
Q
;
DSP(DIEN) ;Display record from file 404.52 for DIEN entry
N SCDAT,SCDT,SCSTA,SCTP
I $G(DIEN)="" Q
S SCDAT=$G(^SCTM(404.52,DIEN,0)),Y=$P(SCDAT,U,2) X ^DD("DD") S SCDT=Y
S SCTP=$P(SCDAT,U) S:SCTP'="" SCTP=$P($G(^SCTM(404.57,SCTP,0)),U)
S SCSTA=$S($P(SCDAT,U,4):"Active",1:"Inactive")
W ?20,DIEN,?27,SCDT,?44,$E(SCTP,1,20),?68,SCSTA,!
Q
;
TPHIS(SCIEN) ;Display complete position history for team position
N ZDATE,ZLIST,ZERROR,SCX,SCY,TP,C,SCSTP,SCNAM
S TP=$P(^SCTM(404.52,SCIEN,0),U) I TP="" Q
S ZDATE("BEGIN")=1,ZDATE("END")=9999999,ZDATE("INCL")=0,SCSTP=0,C=1
S SCX=$$PRTP^SCAPMC(TP,"ZDATE","ZLIST","ZERROR",0,1)
I 'SCX!($D(ZERROR)) Q
W !?25,"TEAM POSITION HISTORY"
W !?10,"Effective Date",?30,"Staff",?54,"Status",!
S SCX=0 F S SCX=$O(ZLIST("ALL",404.52,SCX)) Q:'SCX D I SCSTP Q
. S SCY=ZLIST("ALL",404.52,SCX),SCNAM=$P(SCY,U,6),C=C+1
. I '(C#10) S DIR(0)="E" D ^DIR W ! I 'Y S SCSTP=1 Q
. W:SCNAM="" ?6,"***"
. W ?10,$P(SCY,U,4),?30,$E(SCNAM,1,20),?54,$P(SCY,U,2)
. W:SCNAM="" " ***" W !
Q
;
LST() ;Returns list of invalid entries from file #404.52 for field .03
;This subroutine checks the POSITION ASSIGNMENT HISTORY FILE (#404.52)
;for invalid pointers stored in the PRACTITIONER field (#.03) and
;returns a list of all such entries ien.
;
; Output:-
; ^TMP("PCMM PRACTITIONER",$J,IEN - Name of array to return list
; Array subsripted by ien number
; Returns - 1 if entry found, 0 no entry found
;
N IEN,PRAC
S IEN=0
F S IEN=$O(^SCTM(404.52,IEN)) Q:'IEN I $G(^SCTM(404.52,IEN,0))'="" D
. S PRAC=$P(^SCTM(404.52,IEN,0),U,3)
. I PRAC'>0!('$D(^VA(200,+PRAC))) S ^TMP("PCMM PRACTITIONER",$J,IEN)="" Q
. I $D(^USR(8930.3,"B",PRAC))!('$$USEUSR^SCMCTPU) Q
. S ^TMP("PCMM PRACTITIONER",$J,IEN)=""
Q $S($D(^TMP("PCMM PRACTITIONER",$J)):1,1:0)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCCV5 3797 printed Oct 16, 2024@18:40:40 Page 2
SCMCCV5 ;ALB/JAM;Allow edits of invalid .03 field in 404.52;12/1/99@1055
+1 ;;5.3;Scheduling;**204,297**;DEC 01, 1999
+2 ;
EDIT ;Entry point for cnahes to .03 field in file 404.52
+1 NEW SCEND
+2 DO HDR(0)
+3 SET SCEND=0
+4 FOR
DO PROCESS
IF SCEND
QUIT
+5 KILL DIE,^TMP("PCMM PRACTITIONER",$JOB),DTOUT,DUOUT,DIROUT,DR,DA,X,Y
+6 QUIT
+7 ;
PROCESS ;Get list of invalid .03 field in file 404.52, select and then edit
+1 NEW SCIEN,FND
+2 KILL ^TMP("PCMM PRACTITIONER",$JOB)
+3 SET FND=$$LST()
+4 IF 'FND
WRITE "No Entries found"
SET SCEND=1
QUIT
+5 ;select a valid IEN to edit
+6 SET SCIEN=$$GETIEN()
IF 'SCIEN
SET SCEND=1
QUIT
+7 ;edit .03 field
REP DO TPHIS(SCIEN)
+1 KILL DA,DR,DIE
SET DIE="^SCTM(404.52,"
SET DA=SCIEN
+2 SET DR=".03Practitioner"
DO ^DIE
KILL DR
+3 IF $DATA(DTOUT)!($DATA(DUOUT))
SET SCEND=1
QUIT
+4 IF $GET(Y)<0
QUIT
+5 ;verify practitioner response
+6 KILL DA,DIR,DIROUT,DIRUT,DTOUT,DUOUT
+7 SET DIR(0)="Y"
SET DIR("A")=" ...OK"
SET DIR("B")="Yes"
+8 SET DIR("?")="Enter Yes or <RT> to accept or No to change response"
+9 DO ^DIR
KILL DIR
IF Y
QUIT
+10 IF $DATA(DTOUT)!$DATA(DUOUT)!($DATA(DIROUT))
QUIT
+11 GOTO REP
+12 QUIT
+13 ;
GETIEN() ;Select IEN from FILE 404.52
+1 NEW DIR,X,Y
+2 SET DIR("A")="Select IEN"
SET DIR("?")="^D LSTIEN^SCMCCV5"
+3 SET DIR(0)="FO^^K:'$D(^TMP(""PCMM PRACTITIONER"",$J,X)) X"
+4 DO ^DIR
IF $DATA(DIRUT)
QUIT 0
+5 DO DSP(X)
+6 QUIT X
+7 ;
LSTIEN ;Display a list of .03 entries stored in ^TMP("PCMM PRACTITIONER",$J
+1 NEW IEN,SCSTP
+2 SET (IEN,SCSTP)=0
+3 DO HDR(1)
+4 FOR
SET IEN=$ORDER(^TMP("PCMM PRACTITIONER",$JOB,IEN))
if 'IEN
QUIT
Begin DoDot:1
+5 IF ($Y+3>IOSL)
Begin DoDot:2
+6 SET DIR(0)="E"
SET DIR("A")="Enter RETURN to continue or '^' to exit"
+7 DO ^DIR
if Y
DO HDR(1)
End DoDot:2
IF 'Y
SET SCSTP=1
QUIT
+8 DO DSP(IEN)
End DoDot:1
IF SCSTP
QUIT
+9 IF 'SCSTP
WRITE !,?20,"To Edit, enter an IEN number from the displayed list"
+10 QUIT
+11 ;
HDR(FL) ;Print header for list of invalid entries in file 404.52
+1 WRITE @IOF
+2 WRITE !,?23,$SELECT(FL:"LIST OF",1:"EDITING")_" INVALID PRACTITIONER ENTRY",!!
+3 IF FL
Begin DoDot:1
+4 WRITE ?20,"IEN",?27,"Effective Date",?44,"Team",?68,"Status",!
+5 WRITE ?20,"---",?27,"--------------",?44,"----",?68,"------",!
End DoDot:1
+6 QUIT
+7 ;
DSP(DIEN) ;Display record from file 404.52 for DIEN entry
+1 NEW SCDAT,SCDT,SCSTA,SCTP
+2 IF $GET(DIEN)=""
QUIT
+3 SET SCDAT=$GET(^SCTM(404.52,DIEN,0))
SET Y=$PIECE(SCDAT,U,2)
XECUTE ^DD("DD")
SET SCDT=Y
+4 SET SCTP=$PIECE(SCDAT,U)
if SCTP'=""
SET SCTP=$PIECE($GET(^SCTM(404.57,SCTP,0)),U)
+5 SET SCSTA=$SELECT($PIECE(SCDAT,U,4):"Active",1:"Inactive")
+6 WRITE ?20,DIEN,?27,SCDT,?44,$EXTRACT(SCTP,1,20),?68,SCSTA,!
+7 QUIT
+8 ;
TPHIS(SCIEN) ;Display complete position history for team position
+1 NEW ZDATE,ZLIST,ZERROR,SCX,SCY,TP,C,SCSTP,SCNAM
+2 SET TP=$PIECE(^SCTM(404.52,SCIEN,0),U)
IF TP=""
QUIT
+3 SET ZDATE("BEGIN")=1
SET ZDATE("END")=9999999
SET ZDATE("INCL")=0
SET SCSTP=0
SET C=1
+4 SET SCX=$$PRTP^SCAPMC(TP,"ZDATE","ZLIST","ZERROR",0,1)
+5 IF 'SCX!($DATA(ZERROR))
QUIT
+6 WRITE !?25,"TEAM POSITION HISTORY"
+7 WRITE !?10,"Effective Date",?30,"Staff",?54,"Status",!
+8 SET SCX=0
FOR
SET SCX=$ORDER(ZLIST("ALL",404.52,SCX))
if 'SCX
QUIT
Begin DoDot:1
+9 SET SCY=ZLIST("ALL",404.52,SCX)
SET SCNAM=$PIECE(SCY,U,6)
SET C=C+1
+10 IF '(C#10)
SET DIR(0)="E"
DO ^DIR
WRITE !
IF 'Y
SET SCSTP=1
QUIT
+11 if SCNAM=""
WRITE ?6,"***"
+12 WRITE ?10,$PIECE(SCY,U,4),?30,$EXTRACT(SCNAM,1,20),?54,$PIECE(SCY,U,2)
+13 if SCNAM=""
WRITE " ***"
WRITE !
End DoDot:1
IF SCSTP
QUIT
+14 QUIT
+15 ;
LST() ;Returns list of invalid entries from file #404.52 for field .03
+1 ;This subroutine checks the POSITION ASSIGNMENT HISTORY FILE (#404.52)
+2 ;for invalid pointers stored in the PRACTITIONER field (#.03) and
+3 ;returns a list of all such entries ien.
+4 ;
+5 ; Output:-
+6 ; ^TMP("PCMM PRACTITIONER",$J,IEN - Name of array to return list
+7 ; Array subsripted by ien number
+8 ; Returns - 1 if entry found, 0 no entry found
+9 ;
+10 NEW IEN,PRAC
+11 SET IEN=0
+12 FOR
SET IEN=$ORDER(^SCTM(404.52,IEN))
if 'IEN
QUIT
IF $GET(^SCTM(404.52,IEN,0))'=""
Begin DoDot:1
+13 SET PRAC=$PIECE(^SCTM(404.52,IEN,0),U,3)
+14 IF PRAC'>0!('$DATA(^VA(200,+PRAC)))
SET ^TMP("PCMM PRACTITIONER",$JOB,IEN)=""
QUIT
+15 IF $DATA(^USR(8930.3,"B",PRAC))!('$$USEUSR^SCMCTPU)
QUIT
+16 SET ^TMP("PCMM PRACTITIONER",$JOB,IEN)=""
End DoDot:1
+17 QUIT $SELECT($DATA(^TMP("PCMM PRACTITIONER",$JOB)):1,1:0)
