source: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCCV5.m@ 724

Last change on this file since 724 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.6 KB
Line 
1SCMCCV5 ;ALB/JAM;Allow edits of invalid .03 field in 404.52;12/1/99@1055
2 ;;5.3;Scheduling;**204,297**;DEC 01, 1999
3 ;
4EDIT ;Entry point for cnahes to .03 field in file 404.52
5 N SCEND
6 D HDR(0)
7 S SCEND=0
8 F D PROCESS I SCEND Q
9 K DIE,^TMP("PCMM PRACTITIONER",$J),DTOUT,DUOUT,DIROUT,DR,DA,X,Y
10 Q
11 ;
12PROCESS ;Get list of invalid .03 field in file 404.52, select and then edit
13 N SCIEN,FND
14 K ^TMP("PCMM PRACTITIONER",$J)
15 S FND=$$LST()
16 I 'FND W "No Entries found" S SCEND=1 Q
17 ;select a valid IEN to edit
18 S SCIEN=$$GETIEN() I 'SCIEN S SCEND=1 Q
19 ;edit .03 field
20REP D TPHIS(SCIEN)
21 K DA,DR,DIE S DIE="^SCTM(404.52,",DA=SCIEN
22 S DR=".03Practitioner" D ^DIE K DR
23 I $D(DTOUT)!($D(DUOUT)) S SCEND=1 Q
24 I $G(Y)<0 Q
25 ;verify practitioner response
26 K DA,DIR,DIROUT,DIRUT,DTOUT,DUOUT
27 S DIR(0)="Y",DIR("A")=" ...OK",DIR("B")="Yes"
28 S DIR("?")="Enter Yes or <RT> to accept or No to change response"
29 D ^DIR K DIR I Y Q
30 I $D(DTOUT)!$D(DUOUT)!($D(DIROUT)) Q
31 G REP
32 Q
33 ;
34GETIEN() ;Select IEN from FILE 404.52
35 N DIR,X,Y
36 S DIR("A")="Select IEN",DIR("?")="^D LSTIEN^SCMCCV5"
37 S DIR(0)="FO^^K:'$D(^TMP(""PCMM PRACTITIONER"",$J,X)) X"
38 D ^DIR I $D(DIRUT) Q 0
39 D DSP(X)
40 Q X
41 ;
42LSTIEN ;Display a list of .03 entries stored in ^TMP("PCMM PRACTITIONER",$J
43 N IEN,SCSTP
44 S (IEN,SCSTP)=0
45 D HDR(1)
46 F S IEN=$O(^TMP("PCMM PRACTITIONER",$J,IEN)) Q:'IEN D I SCSTP Q
47 . I ($Y+3>IOSL) D I 'Y S SCSTP=1 Q
48 . . S DIR(0)="E",DIR("A")="Enter RETURN to continue or '^' to exit"
49 . . D ^DIR D:Y HDR(1)
50 . D DSP(IEN)
51 I 'SCSTP W !,?20,"To Edit, enter an IEN number from the displayed list"
52 Q
53 ;
54HDR(FL) ;Print header for list of invalid entries in file 404.52
55 W @IOF
56 W !,?23,$S(FL:"LIST OF",1:"EDITING")_" INVALID PRACTITIONER ENTRY",!!
57 I FL D
58 . W ?20,"IEN",?27,"Effective Date",?44,"Team",?68,"Status",!
59 . W ?20,"---",?27,"--------------",?44,"----",?68,"------",!
60 Q
61 ;
62DSP(DIEN) ;Display record from file 404.52 for DIEN entry
63 N SCDAT,SCDT,SCSTA,SCTP
64 I $G(DIEN)="" Q
65 S SCDAT=$G(^SCTM(404.52,DIEN,0)),Y=$P(SCDAT,U,2) X ^DD("DD") S SCDT=Y
66 S SCTP=$P(SCDAT,U) S:SCTP'="" SCTP=$P($G(^SCTM(404.57,SCTP,0)),U)
67 S SCSTA=$S($P(SCDAT,U,4):"Active",1:"Inactive")
68 W ?20,DIEN,?27,SCDT,?44,$E(SCTP,1,20),?68,SCSTA,!
69 Q
70 ;
71TPHIS(SCIEN) ;Display complete position history for team position
72 N ZDATE,ZLIST,ZERROR,SCX,SCY,TP,C,SCSTP,SCNAM
73 S TP=$P(^SCTM(404.52,SCIEN,0),U) I TP="" Q
74 S ZDATE("BEGIN")=1,ZDATE("END")=9999999,ZDATE("INCL")=0,SCSTP=0,C=1
75 S SCX=$$PRTP^SCAPMC(TP,"ZDATE","ZLIST","ZERROR",0,1)
76 I 'SCX!($D(ZERROR)) Q
77 W !?25,"TEAM POSITION HISTORY"
78 W !?10,"Effective Date",?30,"Staff",?54,"Status",!
79 S SCX=0 F S SCX=$O(ZLIST("ALL",404.52,SCX)) Q:'SCX D I SCSTP Q
80 . S SCY=ZLIST("ALL",404.52,SCX),SCNAM=$P(SCY,U,6),C=C+1
81 . I '(C#10) S DIR(0)="E" D ^DIR W ! I 'Y S SCSTP=1 Q
82 . W:SCNAM="" ?6,"***"
83 . W ?10,$P(SCY,U,4),?30,$E(SCNAM,1,20),?54,$P(SCY,U,2)
84 . W:SCNAM="" " ***" W !
85 Q
86 ;
87LST() ;Returns list of invalid entries from file #404.52 for field .03
88 ;This subroutine checks the POSITION ASSIGNMENT HISTORY FILE (#404.52)
89 ;for invalid pointers stored in the PRACTITIONER field (#.03) and
90 ;returns a list of all such entries ien.
91 ;
92 ; Output:-
93 ; ^TMP("PCMM PRACTITIONER",$J,IEN - Name of array to return list
94 ; Array subsripted by ien number
95 ; Returns - 1 if entry found, 0 no entry found
96 ;
97 N IEN,PRAC
98 S IEN=0
99 F S IEN=$O(^SCTM(404.52,IEN)) Q:'IEN I $G(^SCTM(404.52,IEN,0))'="" D
100 . S PRAC=$P(^SCTM(404.52,IEN,0),U,3)
101 . I PRAC'>0!('$D(^VA(200,+PRAC))) S ^TMP("PCMM PRACTITIONER",$J,IEN)="" Q
102 . I $D(^USR(8930.3,"B",PRAC))!('$$USEUSR^SCMCTPU) Q
103 . S ^TMP("PCMM PRACTITIONER",$J,IEN)=""
104 Q $S($D(^TMP("PCMM PRACTITIONER",$J)):1,1:0)
Note: See TracBrowser for help on using the repository browser.