- SCMCCV5 ;ALB/JAM;Allow edits of invalid .03 field in 404.52;12/1/99@1055
- ;;5.3;Scheduling;**204,297,1015**;DEC 01, 1999;Build 21
- ;
- 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)
- SCMCCV5 ;ALB/JAM;Allow edits of invalid .03 field in 404.52;12/1/99@1055
- +1 ;;5.3;Scheduling;**204,297,1015**;DEC 01, 1999;Build 21
- +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)
